Başka Sayfadan Koşullu ve Kısmi Veri Çekme

[tahsinanarat]

Sn. @Korhan Ayhan Hocam, elinize sağlık çok hızlı çalışan kodlar, bu kodda eğer aranan değer bulunamaz ise bir sonraki satıra geçiyor. Bulumadığı durumda o satırın ilk sutununa aranan değeri yazdırıp diğer sutunları boş bıraktırabilirmiyiz. Teşekkürler

 

[canburak]

Cok tesekkurler Hocam elinize saglik cok guzel calisiyor.

Deneyiniz.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dizi As Object, Aranan As Range, Say As Long
 
    Set S1 = Sheets("data")
    Set S2 = Sheets("raport")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
 
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
 
    Veri = S1.Range("A2:I" & Son).Value
 
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 9) = "Kapali" Then
            If Not Dizi.Exists(Veri(X, 7)) Then
                Dizi.Add Veri(X, 7), Array(Veri(X, 3), Veri(X, 4))
            End If
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
 
    Veri = S2.Range("A2:A" & Son).Value
 
    ReDim Liste(1 To Son - 1, 1 To 3)
     
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Dizi.Item(Veri(X, 1))(0)
            Liste(Say, 3) = Dizi.Item(Veri(X, 1))(1)
        End If
    Next
 
    S2.Range("B2:D" & S2.Rows.Count).ClearContents
 
    If Say > 0 Then S2.Range("B2").Resize(Say, 3) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

@tahsinanarat bey örnek dosya paylaşınız.

 

[tahsinanarat]

Sn. @Korhan Ayhan Bey örnek dosya ekte gönderiyorum.

 

[Korhan Ayhan]

İkinci döngüyü biraz düzenlemek yeterli olacaktır.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Zaman As Double
    Dim Veri As Variant, X As Long, Son As Long
    Dim Dizi As Object, Aranan As Range, Say As Long
   
    Zaman = Timer

    Set S1 = Sheets("data")
    Set S2 = Sheets("raport")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
  
    Veri = S1.Range("A2:I" & Son).Value
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Not Dizi.Exists(Veri(X, 7)) Then
            Dizi.Add Veri(X, 7), Array(Veri(X, 5), Veri(X, 3), Veri(X, 4), Veri(X, 1))
        End If
    Next

    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row

    Veri = S2.Range("A2:A" & Son).Value
  
    ReDim Liste(1 To Son - 1, 1 To 5)
      
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Exists(Veri(X, 1)) Then
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Dizi.Item(Veri(X, 1))(0)
            Liste(Say, 3) = Dizi.Item(Veri(X, 1))(1)
            Liste(Say, 4) = Dizi.Item(Veri(X, 1))(2)
            Liste(Say, 5) = Dizi.Item(Veri(X, 1))(3)
        Else
            Liste(Say, 1) = Veri(X, 1)
        End If
    Next
  
    S2.Range("B2:f" & S2.Rows.Count).ClearContents
  
    If Say > 0 Then S2.Range("B2").Resize(Say, 5) = Liste

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[tahsinanarat]

@Korhan Ayhan hocam çok teşekkür ederim;
Else
Liste(Say, 1) = Veri(X, 1)
End If
bu kısmı denemiştim hata almıştım, ama
Say = Say + 1
If Dizi.Exists(Veri(X, 1)) Then
bu satırların yer değiştirmek aklıma gelmedi. Elinize sağlık. Saygılar

 

[Korhan Ayhan]

@canburak,

Sizin için paylaştığım kodlarda da Say değişkeninin yerini değiştirdim. Bu hali daha doğru sonuç verecektir. Siz de son kodları denersiniz.