Soru Sayfalar Arası Veri Çekme

[murat_fidan]

Arkadaşlar Veri isimli sayfamda ID no sütununa yazdığım verilere ait SAĞLAM yazan verileri PARÇALAR isimli sayfamda bulup Veri sayfamda ilgili başlıkların altına çekmek istiyorum. Yazdığım ID no parçalar sayfasında arızalı durumda ise yada yok ise yok yazsın istiyorum. Örnek durumu veri sayfasında örnekledim. Veri sayım 20 bin satır civarında.

 

[veyselemre]

Sub test()

    Dim sVeri As Worksheet, parcalar, i&, sNo&, idNo
    
    Set sVeri = Sheets("VERİ")
    
    With Sheets("PARÇALAR")
        parcalar = .Range("A2:K" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With
    
    With CreateObject("Scripting.Dictionary")
        
        For i = LBound(parcalar) To UBound(parcalar)
            .Item(parcalar(i, 1)) = i
        Next i
        
        For i = 2 To sVeri.Cells(Rows.Count, 2).End(3).Row
            idNo = sVeri.Cells(i, 2).Value
            If .exists(idNo) Then
                sNo = .Item(idNo)
                
                If parcalar(sNo, 4) = "SAĞLAM" Then
                    sVeri.Cells(i, 1).Value = parcalar(sNo, 2)
                    sVeri.Cells(i, 3).Value = parcalar(sNo, 3)
                    sVeri.Cells(i, 4).Value = parcalar(sNo, 4)
                    sVeri.Cells(i, 5).Value = parcalar(sNo, 6)
                    sVeri.Cells(i, 6).Value = parcalar(sNo, 11)
                Else
                    sVeri.Cells(i, 1).Value = parcalar(sNo, 4)
                End If
            
            Else
                sVeri.Cells(i, 1).Value = "YOK"
            End If
        
        Next i
    
    End With


End Sub

 

[murat_fidan]

Sub test()

    Dim sVeri As Worksheet, parcalar, i&, sNo&, idNo
   
    Set sVeri = Sheets("VERİ")
   
    With Sheets("PARÇALAR")
        parcalar = .Range("A2:K" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With
   
    With CreateObject("Scripting.Dictionary")
       
        For i = LBound(parcalar) To UBound(parcalar)
            .Item(parcalar(i, 1)) = i
        Next i
       
        For i = 2 To sVeri.Cells(Rows.Count, 2).End(3).Row
            idNo = sVeri.Cells(i, 2).Value
            If .exists(idNo) Then
                sNo = .Item(idNo)
               
                If parcalar(sNo, 4) = "SAĞLAM" Then
                    sVeri.Cells(i, 1).Value = parcalar(sNo, 2)
                    sVeri.Cells(i, 3).Value = parcalar(sNo, 3)
                    sVeri.Cells(i, 4).Value = parcalar(sNo, 4)
                    sVeri.Cells(i, 5).Value = parcalar(sNo, 6)
                    sVeri.Cells(i, 6).Value = parcalar(sNo, 11)
                Else
                    sVeri.Cells(i, 1).Value = parcalar(sNo, 4)
                End If
           
            Else
                sVeri.Cells(i, 1).Value = "YOK"
            End If
       
        Next i
   
    End With


End Sub

Veysel bey çok teşekkür ederim kod tam istediğim gibi çalışıyor. Öğrenmek istediğim ben verileri Veri sayfasına yazdığım ID no sütunundan değilde Veri Sayfasında A sütununda bulunan Seri no kısmından çekmek istesem yani seri nolara göre aynı şartlar göz önünde bulundurularak çeksem makroda ne gibi değişiklik yapmak gerekir.