Belli kritere göre data sayfalarından veri çekmek

[selimsayar]

Merhaba Arkadaşlar,
Belli kritere göre data sayfalarından veri çekip rapor oluşturmak istiyorum. Ekli dosyada konuyu anlatmaya çalıştım. Tanımlanan işlemi yapacak makro temin ederseniz sevinirim. Teşekkürler.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Rapor_Al()
    
    Dim syf(), sat As Long, i As Byte, c As Range, Adr As String
    
    Application.ScreenUpdating = False
    Sheets("Rapor").Select
    Range("A4:D" & Rows.Count).ClearContents
    
    syf = Array("Data1", "Data2", "Data3")
    
    sat = 4
    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            Set c = .[D:D].Find([A1], , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    .Cells(c.Row, "A").Resize(1, 3).Copy Cells(sat, "A")
                    Cells(sat, "D") = .Name
                    sat = sat + 1
                    Set c = .[D:D].FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[selimsayar]

Teşekkür ederim Ömer bey. Kod çalışıyor. Sadece macroyu manual olarak çalıştırmam gerekiyor. Dropdown listeden seçtiğim zaman otomatik olarak çalışırsa daha iyi olur.

 

[Ömer]

Rapor sayfası kod bölümüne:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim syf(), sat As Long, i As Byte, c As Range, Adr As String
    
    If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Range("A4:D" & Rows.Count).ClearContents
    If Target = "" Then Exit Sub
    
    syf = Array("Data1", "Data2", "Data3")
    
    sat = 4
    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            Set c = .[D:D].Find([A1], , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    .Cells(c.Row, "A").Resize(1, 3).Copy Cells(sat, "A")
                    Cells(sat, "D") = .Name
                    sat = sat + 1
                    Set c = .[D:D].FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[selimsayar]

Teşekkürler.