4-5 Sayfadaki Verileri Tek Sayfada listeleme

[kegat28]

Arkadaşlar forumda araştırdım ama açıkcası beceremedim. Ekli dosyanın 4-5 sayfasındaki verileri Ozet sayfasınında 9.satırdaki kriterlere (biri,birkaçı ve tümü) göre nasıl listeleyebilirim. Şimdiden ilgilerinize teşekkür ederim.

 

[Ferhat Pazarçevirdi]

Örnek dosyayı inceleyiniz.

Kodlar şu şekilde dizayn edildi. Eğer kodları kopyalama usulü kullanacaksanız, VBA Projenize, Microsoft Activex Data Object Recordset X.X Library referansını eklemelisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rs As ADOR.Recordset
    Dim rng As Range, rngKayit As Range
    Dim wks As Worksheet
    Dim iSon As Integer, iIlkCol As Integer, i As Integer
    Dim sKriter As String
    
    On Error GoTo HataYakalayici
    
    Set rs = New ADOR.Recordset
    
    With rs
        With .Fields
            For Each rng In Range("A9:N9").Cells
                .Append rng, adChar, 50
            Next
        End With
        .CursorLocation = adUseClient
        .CursorType = adOpenForwardOnly
        .Open
    End With
    
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name <> "OZET" Then
            iSon = wks.Cells(65536, 1).End(xlUp).Row
            If iSon <= 10 Then
                GoTo fpc
            Else
                Set rngKayit = wks.Range("A11:N" & iSon)
                For Each rng In rngKayit.Cells
                    If rng.Column = 1 Then rs.AddNew
                    rs.Fields(rng.Column - 1) = CStr(rng)
                Next
            End If
        End If
    Next
    
        
    If Len(Cells(10, 1)) > 0 Then
        iIlkCol = 1
    Else
        iIlkCol = Cells(10, 1).End(xlToRight).Column
    End If
    
    If iIlkCol <= 14 Then
        sKriter = rs.Fields(iIlkCol - 1).Name & "='" & Cells(10, iIlkCol) & "'"
        For i = iIlkCol + 1 To 14
            If Len(Cells(10, i)) > 0 Then
                sKriter = sKriter & " AND " & rs.Fields(i - 1).Name & "='" & Cells(10, i) & "'"
            End If
        Next i
        rs.Filter = sKriter
    End If
    Application.EnableEvents = False
    
    If Cells(65536, 1).End(xlUp).Row > 10 Then
        Range("A11:N" & Cells(65536, 1).End(xlUp).Row + 1).ClearContents
    End If
    
    If rs.RecordCount > 0 Then
        rs.MoveFirst
        Range("A11").CopyFromRecordset rs
    End If
    
    Application.EnableEvents = True
fpc:
    rs.Close
HataYakalayici:
    
    If Err > 0 Then
        MsgBox Err.Number, vbCritical, "Şu hata ile karşılaşıldı"
    End If
    
    Set rngKayit = Nothing
    Set rs = Nothing
        
End Sub