Koşullu Combobox

[datcrack]

Merhaba,
Ekteki excel dosyasında "Sheet1" sayfasında bir datamız var.
Bu dataya bağlı olarak "Rapor" sayfasında bir çalışma yapmak istiyorum. Rapor sayfasında her bir 30 satır için tüm hücreler lisbox olacak.(Yani veri doğrulama gibi bir açılır liste ya da combobox) Burada mesela C4'te listeden şehir seçtiğimde; "Sheet1" sayfasındaki 200 satırlık datadan sadece o şehirlerin ilçeleri listelensin.. İlçeyi seçtiğimde ise sadece o ilçedeki bankalar listelensin.. Bankayı seçtiğimde ise ATM'nin var-yok seçeneği gelsin.
Bu dosyanın çok daha karmaşıkları yapılmış ancak bir türlü bu çalışmayı yapamadım.
Destek olabilirseniz çok memnun olurum,
Herkese selamlar, şimdiden iyi bayramlar dilerim..

https://we.tl/t-QkaiMEDV0y

 

[Ömer]

Merhaba,

Rapor sayfası kod bölümüne kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim S1 As Worksheet, a As String, c As Range, Adr As String
    
    Set S1 = Sheets("Sheet1")
    
    If Intersect(Target, [E4:E33]) Is Nothing Then Exit Sub
    
    With Target
        Cells(.Row, "F") = ""
        Set c = S1.[D:D].Find(Target, , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                If S1.Cells(c.Row, "B") = Cells(.Row, "C") Then
                    a = Cells(.Row, "D")
                    If Cells(.Row, "D") = "" Then a = S1.Cells(c.Row, "C")
                    If S1.Cells(c.Row, "C") = a Then
                        Cells(.Row, "F") = S1.Cells(c.Row, "E")
                        Exit Do
                    End If
                End If
                Set c = S1.[D:D].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim S1 As Worksheet, d As Object, son As Long, deg As String, i As Long, a As String

    If Intersect(Target, [C4:E33]) Is Nothing Then Exit Sub
    
    Set S1 = Sheets("Sheet1")
    Set d = CreateObject("Scripting.Dictionary")
    son = S1.Cells(Rows.Count, "B").End(xlUp).Row
    
    With Target
        If .Column = 3 Then
            Cells(.Row, "D").Resize(1, 3) = ""
            .Validation.Delete
            For i = 3 To son
                deg = S1.Cells(i, "B")
                If Not d.exists(deg) Then
                    d.Add deg, Nothing
                End If
            Next i
            .Validation.Add Type:=xlValidateList, Formula1:=Join(d.keys, ",")
            Set d = Nothing
        End If
        If .Column = 4 Then
           Cells(.Row, "E").Resize(1, 2) = ""
            .Validation.Delete
            If Cells(.Row, "C") <> "" Then
                For i = 3 To son
                    If S1.Cells(i, "B") = Cells(.Row, "C") Then
                        deg = S1.Cells(i, "C")
                        If Not d.exists(deg) Then
                            d.Add deg, Nothing
                        End If
                    End If
                Next i
                .Validation.Add Type:=xlValidateList, Formula1:=Join(d.keys, ",")
                Set d = Nothing
            End If
        End If
        If .Column = 5 Then
            Cells(.Row, "F") = ""
            .Validation.Delete
            If Cells(.Row, "C") <> "" Or Cells(.Row, "D") <> "" Then
                For i = 3 To son
                    If S1.Cells(i, "B") = Cells(.Row, "C") Then
                        a = Cells(.Row, "D")
                        If Cells(.Row, "D") = "" Then a = S1.Cells(i, "C")
                        If S1.Cells(i, "C") = a Then
                            deg = S1.Cells(i, "D")
                            If Not d.exists(deg) Then
                                d.Add deg, Nothing
                            End If
                        End If
                    End If
                Next i
                .Validation.Add Type:=xlValidateList, Formula1:=Join(d.keys, ",")
                Set d = Nothing
            End If
        End If
    End With
    
End Sub

.