Aranılan kritere göre liste oluşturmak

[csncesur]

A sütununda illerin ismi mevcut. K1 hücresine il ismi girdiğim zaman A sütunundaki ilin karşısında bulunan ilçe isimlerini yinelenensiz bir şekilde K2:K30 hücrelerine listelenmesini istiyorum.

 

[veyselemre]

Sub test()

    Dim veri, krt$, rng As Range, i%, ii%

    With Sheets("Sayfa1")
        veri = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
        krt = .Range("K1").Value
        Set rng = .Range("K2")
        rng.Resize(100).ClearContents
    End With

    With CreateObject("Scripting.Dictionary")
        For i = LBound(veri) To UBound(veri)
            If veri(i, 1) = krt Then
                .Item(veri(i, 2)) = Null
            End If
        Next i
        veri = .keys
        For i = LBound(veri) To UBound(veri) - 1
            For ii = i + 1 To UBound(veri)
                If Not StrComp(veri(i), veri(ii), vbTextCompare) Then
                    krt = veri(i)
                    veri(i) = veri(ii)
                    veri(ii) = krt
                End If
            Next ii
        Next i
    End With

    rng.Resize(UBound(veri) + 1).Value = Application.Transpose(veri)

End Sub

 

[csncesur]

Sub test()

    Dim veri, krt$, rng As Range, i%, ii%

    With Sheets("Sayfa1")
        veri = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
        krt = .Range("K1").Value
        Set rng = .Range("K2")
        rng.Resize(100).ClearContents
    End With

    With CreateObject("Scripting.Dictionary")
        For i = LBound(veri) To UBound(veri)
            If veri(i, 1) = krt Then
                .Item(veri(i, 2)) = Null
            End If
        Next i
        veri = .keys
        For i = LBound(veri) To UBound(veri) - 1
            For ii = i + 1 To UBound(veri)
                If Not StrComp(veri(i), veri(ii), vbTextCompare) Then
                    krt = veri(i)
                    veri(i) = veri(ii)
                    veri(ii) = krt
                End If
            Next ii
        Next i
    End With

    rng.Resize(UBound(veri) + 1).Value = Application.Transpose(veri)

End Sub

Hocam sayfa 1 in kod bölümüne yapıştırdım listelemedi

 

[veyselemre]

Listelemesi için çalıştırmanız gerekir.
Otomatik çalışmasi için sayfa1 in kod sayfasına aşağıdaki kodu ekleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Target.Address = "$K$1" Then Exit Sub
    Dim veri, krt$, rng As Range, i%, ii%

    With Sheets("Sayfa1")
        veri = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
        krt = .Range("K1").Value
        Set rng = .Range("K2")
        rng.Resize(100).ClearContents
    End With

    With CreateObject("Scripting.Dictionary")
        For i = LBound(veri) To UBound(veri)
            If veri(i, 1) = krt Then
                .Item(veri(i, 2)) = Null
            End If
        Next i
        veri = .keys
        If UBound(veri) > -1 Then
            For i = LBound(veri) To UBound(veri) - 1
                For ii = i + 1 To UBound(veri)
                    If Not StrComp(veri(i), veri(ii), vbTextCompare) Then
                        krt = veri(i)
                        veri(i) = veri(ii)
                        veri(ii) = krt
                    End If
                Next ii
            Next i
            rng.Resize(UBound(veri) + 1).Value = Application.Transpose(veri)
        End If
    End With
End Sub

 

[csncesur]

Listelemesi için çalıştırmanız gerekir.
Otomatik çalışmasi için sayfa1 in kod sayfasına aşağıdaki kodu ekleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Target.Address = "$K$1" Then Exit Sub
    Dim veri, krt$, rng As Range, i%, ii%

    With Sheets("Sayfa1")
        veri = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
        krt = .Range("K1").Value
        Set rng = .Range("K2")
        rng.Resize(100).ClearContents
    End With

    With CreateObject("Scripting.Dictionary")
        For i = LBound(veri) To UBound(veri)
            If veri(i, 1) = krt Then
                .Item(veri(i, 2)) = Null
            End If
        Next i
        veri = .keys
        If UBound(veri) > -1 Then
            For i = LBound(veri) To UBound(veri) - 1
                For ii = i + 1 To UBound(veri)
                    If Not StrComp(veri(i), veri(ii), vbTextCompare) Then
                        krt = veri(i)
                        veri(i) = veri(ii)
                        veri(ii) = krt
                    End If
                Next ii
            Next i
            rng.Resize(UBound(veri) + 1).Value = Application.Transpose(veri)
        End If
    End With
End Sub

Hocam elinize sağlık çok teşekkür ederim