Açılır Kutuları Seçerek Veri almak

[Ahmet Sami]

İyi günler arkadaşlar, örnekte gönderdiğim açılır kutulardan hangisi veya hangilerini seçersem seçeyim KAYIT sayfasından RAPOR kısmına yani bu sayfaya aktaracak.
Tüm açılır kutulardan tamamın seçimi ile değil bir veya bir kaçından da aktarma yapılabilecek yani hangi ve hangilerini seçersem onları aktaracak.
Yardımlarınız için şimdiden teşekkür ederim.

 

[Ahmet Sami]

Yardımcı olabilecek bir abimiz yok mudur?

 

[Ömer]

Merhaba,

Deneyiniz.

Sub aktar()
    
    Dim S1 As Worksheet, son As Long, alan, i As Long, s As Long, j As Byte
    
    Set S1 = Sheets("KAYIT")
    
    Application.ScreenUpdating = False
    Range("A5:I" & Rows.Count).ClearContents
    
    son = S1.Cells(Rows.Count, "A").End(xlUp).Row
    alan = S1.Range("A2:I" & son).Value

    ReDim dizi(1 To son, 1 To 9)

    For i = LBound(alan) To UBound(alan)
        If Range("B1") = "" Or alan(i, 3) = Range("B1") Then
            If Range("C1") = "" Or alan(i, 4) = Range("C1") Then
                If Range("D1") = "" Or alan(i, 5) = Range("D1") Then
                    If Range("E1") = "" Or alan(i, 6) = Range("E1") Then
                        s = s + 1
                        For j = 1 To 9
                            dizi(s, j) = alan(i, j)
                        Next j
                    End If
                End If
            End If
        End If
    Next i
  
    If s > 0 Then Range("A5").Resize(s, 9) = dizi
    Application.ScreenUpdating = True
    
End Sub

 

[Ahmet Sami]

Ömer bey çok teşekkür ederim elinize emeğinize sağlık.