Farklı sayfalar da ki benzersiz verileri alt alta getirmek

[coktansecmeli]

Merhaba arkadaşlar,
3 farklı isim listesinde isimler var bu listedeki bazı isimler sadece o listeye ait bazıları ise diğer listelerde de var.
Benim ihtiyacım olan şu:
Bu 3 farklı listede ki isimleri 4. bir sayfada benzersiz olarak alt alta getirmek.
Eklediğim örnek dosyada olduğu gibi liste1, liste2 ve liste3 de ki A kolonunda ki isimleri benzersiz olarak ana listeye alt alta getirilmesi gerekiyor.

Yardımcı olan herkese şimdiden teşekkürler.

 

[Ömer]

Merhaba,

Deneyiniz.

Sub Ozet()
    
    Dim syf(), d As Object, i As Integer, j As Long, deg, son As Long
        
    syf = Array("Liste1", "Liste2", "Liste3")
    
    Set d = CreateObject("Scripting.Dictionary")

    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            son = .Cells(Rows.Count, "A").End(xlUp).Row
            For j = 1 To son
                deg = .Cells(j, "A")
                If deg <> "" Then
                    If Not d.exists(deg) Then
                        d.Add deg, Nothing
                    End If
                End If
            Next j
        End With
    Next i
 
    Application.ScreenUpdating = False
    Sheets("Ana Liste").Select
    Range("A2:A" & Rows.Count).ClearContents
    Range("A2").Resize(d.Count) = Application.Transpose(d.Keys)

    MsgBox "Aktarım Tamamlandı.", vbInformation
    
End Sub

 

[coktansecmeli]

Çok teşekkür ederim oldu yalnız ufak bir problem var. Başlık ve boşluğun gelmemesi gerekiyor.

 

[Ömer]

Deneyiniz.

Sub Ozet()
    
    Dim syf(), d As Object, i As Integer, j As Long, deg, son As Long
        
    syf = Array("Liste1", "Liste2", "Liste3")
    
    Set d = CreateObject("Scripting.Dictionary")

    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            son = .Cells(Rows.Count, "A").End(xlUp).Row
            For j = 2 To son
                deg = .Cells(j, "A")
                If deg <> "" Then
                    If Not d.exists(deg) Then
                        d.Add deg, Nothing
                    End If
                End If
            Next j
        End With
    Next i
 
    Application.ScreenUpdating = False
    Sheets("Ana Liste").Select
    Range("A1:A" & Rows.Count).ClearContents
    Range("A1").Resize(d.Count) = Application.Transpose(d.Keys)

    MsgBox "Aktarım Tamamlandı.", vbInformation
    
End Sub

 

[coktansecmeli]

çok teşekkürler elinize emeğinize sağlık.

 

[ordulu82]

Deneyiniz.

Sub Ozet()
   
    Dim syf(), d As Object, i As Integer, j As Long, deg, son As Long
       
    syf = Array("Liste1", "Liste2", "Liste3")
   
    Set d = CreateObject("Scripting.Dictionary")

    For i = 0 To UBound(syf)
        With Sheets(syf(i))
            son = .Cells(Rows.Count, "A").End(xlUp).Row
            For j = 2 To son
                deg = .Cells(j, "A")
                If deg <> "" Then
                    If Not d.exists(deg) Then
                        d.Add deg, Nothing
                    End If
                End If
            Next j
        End With
    Next i

    Application.ScreenUpdating = False
    Sheets("Ana Liste").Select
    Range("A1:A" & Rows.Count).ClearContents
    Range("A1").Resize(d.Count) = Application.Transpose(d.Keys)

    MsgBox "Aktarım Tamamlandı.", vbInformation
   
End Sub

Üstad benim listemde veriler B7 , C7 ve D7 hücrelerinde yani 3 farklı hücreden veri almam gerekiyor. Bunları başka sayfada B7 , C7 ve D7 hücrelerine aktarmak istersek makroyu nasıl düzenlememiz gerekiyor.