mükerrer veriler hangi aya ait

[honestman]

Merhaba,


Ekte, çeşitli aylara ait numaralar bulunmakta ve bir numara birden fazla ayda bulunmakta. İsteğim hangi plakanın hangi aylarda bulunduğunu listelemek. Vlookup yada Hlookup ile denedim ama olmadı... Teşekkürler.

 

[honestman]

yardım rica ederim.

 

[Necdet]

Merhaba,

Sanırım konu pek iyi anlaşılmadı. Sadece 2 sütun açmışsınız mükerrer varsa diye, diğer aylar için düşünmüyor musunuz?

 

[honestman]

Merhaba Necdet bey. Diğer aylar için de düşünüyorum Mesjı ve ekteki dosyayı güncelledim teşekkürler.

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz. Farklı yöntemle de yapılabilir. Ay sayısı önemli değil. Listeyi Son kolondan 2 kolon sonra listeler. Geçici bir sayfa üzerinde çalıştım. Adı "Deneme" eğer dosyanızda böyle bir sayfa varsa Koddaki sayfa adını değiştirebilirsiniz.

 Sub TekrarlananBul()
    Dim i       As Long, _
        j       As Long, _
        m       As Long, _
        k       As Integer, _
        Kol     As Integer, _
        Aylar   As String, _
        Syf     As String, _
        Sh1     As Worksheet, _
        Plaka, _
        Dic, _
        iList, _
        kList
    
    Set Dic = CreateObject("Scripting.Dictionary")
    Syf = ActiveSheet.Name
    Set Sh1 = Sheets(Syf)
    Application.ScreenUpdating = False
    
    Kol = Range("A1").End(xlToRight).Column
    
    Range(Cells(1, Kol + 2), Cells(Rows.Count, Kol + 3)).ClearContents
    
    Sheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "Deneme"
    
    For k = 1 To Kol
        i = Sh1.Cells(Rows.Count, k).End(3).Row
        j = Cells(Rows.Count, "A").End(3).Row + 1
        Sh1.Range(Sh1.Cells(2, k), Sh1.Cells(i, k)).Copy Range("A" & j)
        Range("B" & j) = Sh1.Cells(1, k)
        Range("B" & j & ":B" & j + i - 2).FillDown
    Next k
    
    j = j + i - 2
    Range("A2:B" & j).Sort Key1:=Range("A1")
    i = 0
    Plaka = Range("A2")
    
    For m = 2 To j
        Plaka = Cells(m, "A")
        If Application.WorksheetFunction.CountIf(Range("A2:A" & j), Cells(m, "A")) > 1 Then
            If Not Dic.Exists(Plaka) Then
                Dic.Add Plaka, Cells(m, "B")
            Else
                Aylar = Dic.Item(Plaka) & ", " & Cells(m, "B")
                Dic.Item(Plaka) = Aylar
            End If
        End If
    Next m
    
    Sh1.Select
    
    kList = Dic.Keys
    iList = Dic.items
    Range(Cells(1, Kol + 2), Cells(1, Kol + 2)).Resize(UBound(kList) + 1, 1) = Application.WorksheetFunction.Transpose(kList)
    Range(Cells(1, Kol + 3), Cells(1, Kol + 3)).Resize(UBound(kList) + 1, 1) = Application.WorksheetFunction.Transpose(iList)
    
    Application.DisplayAlerts = False
    Sheets("Deneme").Delete
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub

 

[honestman]

Çok teşekkür ederim.

 

[Necdet]

Merhaba,

Kodda bir kontrolü unutmuşum, kodları ve dosyayı yeniledim. Güle güle kullanınız.