benzersiz listeleme

[Pırıl...]

Güzel bir haftanız olsun

1-2-3-4 nolu sayfalarda farklı sütınlardaki isimlerin ,benzersiz olarak özet sayfasında
nasıl toplarım yardımlarınız için şimdiden teşekürler

İndir Kitap1

Dosyayı indir Kitap1

dosya.co

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub OzetAl()

    Dim d As Object, j As Integer, deg, i As Range, sat As Long, alan As Range

    Set d = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
    Set alan = Range("A2:F" & Rows.Count) 'aralık beliryebirsiniz.
    'örnekte sayfalarda A:F aralığında arama yapar

    For j = 1 To Sheets.Count
        If Sheets(j).Name <> "özet" Then
            sat = Sheets(j).Range(alan.Address).Find("*", , , , xlByRows, xlPrevious).Row
            For Each i In Sheets(j).Range(Replace(alan.Address, Rows.Count, sat))
                If i <> "" Then
                    deg = i.Value
                    If Not d.exists(deg) Then
                        d.Add deg, Nothing
                    End If
                End If
            Next i
        End If
    Next j
   
    Sheets("özet").Select
    Range("A2:A" & Rows.Count).ClearContents
    Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys)

End Sub

 

[Pırıl...]

teşekürler Ömer bey ,
gayet başarılı ama formülle yapabilirmisiniz acaba ? sütun yerleri zaman zaman değişiyor ,müdahale etmem kolay olacaktır..

 

[Pırıl...]

Formülle ilgili bir çalışmaya ihtiyacım vardı ,yardımcı olurmusunuz lütfen

 

[Ömer]

Deneme yapmadım fakat, sayfalar arası olduğu için yardımcı sütun yada sütunlar veya yine ktf için makro kullanmanız gerekebilir. Buda süreci uzatacağından tavsiye etmem.

Örnekteki kodu değiştirerek aralık belirleyebileceğiniz bir alan belirttim.

 

[Pırıl...]

Teşekür ederim hocam ,
bir sorum daha olacak bu calışmamda , 4 ten fazla sayfa var ve sadece 4 sayfadan veri alacağım ,
yani sayfa isim ve kolonu belirtir bir revizyon yapma şansınız varmı zahmet olmasa

 

[Ömer]

Bu şekilde deneyin.
Eğer her sayfanın sütunu belliyse onuda tanımlayabiliriz. Sayfaları tanımladım, sütunu ise A:F olarak genel tanımladım.

Sub OzetAl()

    Dim d As Object, j As Integer, deg, i As Range, sat As Long, alan As Range, syf()

    Set d = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
  
    syf = Array("1", "2", "3", "4") 'sayfa adları
    Set alan = Range("A2:F" & Rows.Count) 'aralık beliryebirsiniz.
    'örnekte sayfalarda A:F aralığında arama yapar

    For j = 0 To UBound(syf)
        sat = Sheets(syf(j)).Range(alan.Address).Find("*", , , , xlByRows, xlPrevious).Row
        For Each i In Sheets(syf(j)).Range(Replace(alan.Address, Rows.Count, sat))
            If i <> "" Then
                deg = i.Value
                If Not d.exists(deg) Then
                    d.Add deg, Nothing
                End If
            End If
        Next i
    Next j

    Sheets("özet").Select
    Range("A2:A" & Rows.Count).ClearContents
    Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys)

End Sub

 

[Pırıl...]

Bu şekilde deneyin.
Eğer her sayfanın sütunu belliyse onuda tanımlayabiliriz. Sayfaları tanımladım, sütunu ise A:F olarak genel tanımladım.

Sub OzetAl()

    Dim d As Object, j As Integer, deg, i As Range, sat As Long, alan As Range, syf()

    Set d = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
 
    syf = Array("1", "2", "3", "4") 'sayfa adları
    Set alan = Range("A2:F" & Rows.Count) 'aralık beliryebirsiniz.
    'örnekte sayfalarda A:F aralığında arama yapar

    For j = 0 To UBound(syf)
        sat = Sheets(syf(j)).Range(alan.Address).Find("*", , , , xlByRows, xlPrevious).Row
        For Each i In Sheets(syf(j)).Range(Replace(alan.Address, Rows.Count, sat))
            If i <> "" Then
                deg = i.Value
                If Not d.exists(deg) Then
                    d.Add deg, Nothing
                End If
            End If
        Next i
    Next j

    Sheets("özet").Select
    Range("A2:A" & Rows.Count).ClearContents
    Range("A2").Resize(d.Count, 1) = Application.Transpose(d.keys)

End Sub

çok teşekkür ederim Ömer bey