Farkli Sayfalardan Tek Liste Yapmak

[baydeniro]

Merhaba arkadaşlar. Bir dosyasında birden fazla sayfa var ve bu sayfalarda şehir isimleri bulunuyor. Bu şehirlerden bazılar diğer sayfalarda da bulunmaktadır. TEK LISTE sayfasına tüm sayfalarda bulunan şehirlerden sadece benzersiz/unical bir liste oluşturmak mümkün mü ? Macro veya formül olabilir. Örnek dosya ekte.

 

[turist]

Dosyanız eklidir. İnceleyiniz.

Not: Sayfalardaki şehir isimleri "TEK" olarak yazılmalıdır.
Örnek Edirne 2 defa yazılmıştı düzeltildi.

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub tekliste59()
Dim sh As Worksheet, i As Long, sat As Long
Dim z As Object, liste()
Dim j As Long
Sheets("TEK LISTE").Select
Application.ScreenUpdating = False
Range("B2:B" & Rows.Count).Clear
Set z = CreateObject("Scripting.dictionary")
For i = 1 To Worksheets.Count - 1
    liste = Sheets(i).Range("A2:A" & Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row).Value
    For j = LBound(liste) To UBound(liste)
        If Not z.exists(liste(j, 1)) Then
            z.Add liste(j, 1), Nothing
        End If
    Next j
    Erase liste
Next i
Range("B2").Resize(z.Count, 1) = Application.Transpose(Array(z.keys))
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName
End Sub

 

[baydeniro]

Sayın turist ilginizen çok teşekkür ederim. Aradığım konu sayfa toplamları değil de şehir isimlerinden tek liste yapmak. Şehir isimlerini örnek olarak koymuştum.

 

[baydeniro]

Sayın Orion1 çok teşekkürler. Elleriniz dert görmesin.

 

[tahsinanarat]

Sn. @Orion1 3 nolu mesajınızda, saadece iki sayfanın verilerini birleştirmek istersek, mesala saadece ŞUBE_1 ve ŞUBE_2 de belirtilen şehirleri TEK LİSTE yapmak istersek kodda nasıl bir değişiklik yapmalıyız. Teşekkürler

 

[Orion1]

Buyurun.

Option Base 1
Sub tekliste59()
Dim sh As Worksheet, i As Long, sat As Long
Dim z As Object, liste()
Dim j As Long
Sheets("TEK LISTE").Select
Application.ScreenUpdating = False
Range("B2:B" & Rows.Count).Clear
Set z = CreateObject("Scripting.dictionary")
Set sh = Sheets("Sube_1")
For i = 1 To 2
    liste = Sh.Range("A2:A" & Sh.Cells(Rows.Count, "A").End(xlUp).Row).Value
    For j = LBound(liste) To UBound(liste)
        If Not z.exists(liste(j, 1)) Then
            z.Add liste(j, 1), Nothing
        End If
    Next j
    Erase liste
    Set sh = Sheets("Sube_2")
Next i
Range("B2").Resize(z.Count, 1) = Application.Transpose(Array(z.keys))
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName
End Sub

 

[tahsinanarat]

Sn. @Orion1 Çok teşekkür ederim, Bende şöyle bir çözüm üretmiştim

Option Base 1
Sub tekliste59()
Dim sh As Worksheet, i As Long, sat As Long
Dim z As Object, liste()
Dim j As Long
Sheets("TEK LISTE").Select
Application.ScreenUpdating = False
Range("a3:a" & Rows.Count).Clear
Set z = CreateObject("Scripting.dictionary")

sa = Array("SUBE_1", "SUBE_2")
For i = 1 To 2
    liste = Sheets(sa(i)).Range("A2:A" & Sheets(sa(i)).Cells(Rows.Count, "A").End(xlUp).Row).Value
    For j = LBound(liste) To UBound(liste)
        If Not z.exists(liste(j, 1)) Then
            z.Add liste(j, 1), Nothing
        End If
    Next j
    Erase liste
Next i
Range("a3").Resize(z.Count, 1) = Application.Transpose(Array(z.keys))
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName
End Sub

Hayırlı geceler diliyorum. Saygılar.

 

[Orion1]

İyi geceler.