Karışık listeleme

[orkuncan5]

çocuklarının adı aynı olan baba isimlerini listelemek konusunda yardımınıza ihtiyacım var.Sorum daha ayrıntılı ektedir

 

[orkuncan5]

çocuklarının adı aynı olan baba isimlerini listelemek konusunda yardımınıza ihtiyacım var.Sorum daha ayrıntılı ektedir

 

[orkuncan5]

Formda aradım ama bu mantığa göre kod bulamadım ve kendimde uyarlayamadım.Yardım bekliyorum.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu UserForm1 isimli formunuzun kod bölümüne uygulayıp denermisiniz.

Private Sub UserForm_Initialize()
    Dim SD As Object, S1 As Worksheet, S2 As Worksheet, Hücre As Range, X As Long
    Dim Bul As Range, Adres As String, Sütun, Y As Byte, Satır As Long
 
    Application.ScreenUpdating = False
 
    Set SD = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Sayfa2")
    Set S2 = Sheets.Add
 
    With S2
 
        For Each Hücre In S1.Range("C2:D" & S1.Cells(Rows.Count, 1).End(3).Row)
            If Not SD.exists(Hücre.Value) Then
                SD.Add Hücre.Value, Nothing
                X = X + 1
                .Cells(X, 1) = Hücre.Value
            End If
        Next
 
        .Columns("A:A").Sort Key1:=.Range("A1"), Order1:=xlAscending
 
        For X = 1 To .Cells(Rows.Count, 1).End(3).Row
            Set Bul = S1.Range("C:D").Find(.Cells(X, 1), , , xlWhole)
            If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If WorksheetFunction.CountIf(.Range("B" & X & ":IV" & X), S1.Cells(Bul.Row, 1)) = 0 Then
                    .Cells(X, 256).End(1).Offset(0, 1) = S1.Cells(Bul.Row, 1)
                End If
            Set Bul = S1.Range("C:D").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        Next
 
        Sütun = .Cells(1, 1).CurrentRegion.Columns.Count
 
        With ListView1
            .View = lvwReport
            .FullRowSelect = True
            .Gridlines = True
            .LabelEdit = lvwManual
            .ListItems.Clear
            .ColumnHeaders.Clear
            .FlatScrollBar = False
 
            With .ColumnHeaders
                .Add , , "ÇOCUK ADI", 75
 
                For X = 1 To Sütun - 1
                    .Add , , "BABA ADI-" & X, 75
                Next
            End With
 
            For X = 1 To S2.Cells(Rows.Count, 1).End(3).Row
                .ListItems.Add , , S2.Cells(X, 1)
                Satır = Satır + 1
                For Y = 2 To Sütun
                    .ListItems(Satır).SubItems(Y - 1) = S2.Cells(X, Y)
                Next
            Next
        End With
 
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
 
    Set SD = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
End Sub

 

[orkuncan5]

Sizler dahi insanlarsınız Maşallah.Çok teşekkür ederim .Tam istediğim gibi olmuş.Sağolun.