düşeyara ile diğer tablodan makro yardımıyla veri çekme

[meleklerim]

Arkadaşlar, aşağıdaki makro ile ODELIST listemden F1 sayfasının A, F G sütunlarına veri aktarıyorum.
C sütununa listemden değil de "DATA" sayfasındaki tablodan düşeyara ile bir bilgi getirmek için nasıl eklemeler yapmalıyım. Data sayfasındaki bakacağı satır F1 sayfasının A sütununda

diyelim c3 hücresine
=DÜŞEYARA(A3;data!A2:Q2000;5;0) yazacak bir makro satırına ihtiyacım var.


bu formülü elle yazıp çoğaltmak sayfalar dolusu makroya sebep olacağı için,
makro ile ODELIST teki satır sayısı (RNG) kadar yazması daha kullanışlı olacağını düşündüm ama yapamadım.



Private Sub F1LISTELE()
Worksheets("F1").Select
Range("A3:K10000").Select
Selection.ClearContents

Dim i As Integer

With Me.ODELIST
Worksheets("F1").Cells(2, "A") = .ColumnHeaders.Item(1)
Worksheets("F1").Cells(2, "F") = .ColumnHeaders.Item(9)
Worksheets("F1").Cells(2, "G") = .ColumnHeaders.Item(10)

For i = 1 To .ListItems.Count
RNG = Worksheets("F1").Range("A100000").End(xlUp).Row + 1
Worksheets("F1").Range("A" & RNG) = .ListItems(i).Text
Worksheets("F1").Range("F" & RNG) = .ListItems(i).ListSubItems(8).Text
Worksheets("F1").Range("G" & RNG) = .ListItems(i).ListSubItems(9).Text

Worksheets("F1").Range("B" & RNG) = .ListItems(i)
Next i
.Refresh
End With

End Sub

 

[pitchoute]

Private Sub F1LISTELE()
    Worksheets("F1").Select
    Range("A3:K10000").Select
    Selection.ClearContents
    
    Dim i As Integer
    
    With Me.ODELIST
        Worksheets("F1").Cells(2, "A") = .ColumnHeaders.Item(1)
        Worksheets("F1").Cells(2, "F") = .ColumnHeaders.Item(9)
        Worksheets("F1").Cells(2, "G") = .ColumnHeaders.Item(10)
        
        For i = 1 To .ListItems.Count
            RNG = Worksheets("F1").Range("A100000").End(xlUp).Row + 1
            Worksheets("F1").Range("A" & RNG) = .ListItems(i).Text
            Worksheets("F1").Range("F" & RNG) = .ListItems(i).ListSubItems(8).Text
            Worksheets("F1").Range("G" & RNG) = .ListItems(i).ListSubItems(9).Text
            
            ' Burada DÜŞEYARA formülünü C sütununa ekliyoruz
            Worksheets("F1").Range("C" & RNG).FormulaLocal = "=DÜŞEYARA(A" & RNG & ";data!A2:Q2000;5;0)"
            
            Worksheets("F1").Range("B" & RNG) = .ListItems(i)
        Next i
        .Refresh
    End With
    
End Sub

Deneyip sonucu paylaşabilir misiniz.

 

[meleklerim]

çok teşekkür ederim saat gibi çalışıyor

 

[pitchoute]

Rica ederim, iyi çalışmalar.