Sutundaki aynı hücreleri tesbit edip bir defa yazdırma

[bigevv]

B sütunda aynı hücreden birden fazla veri var. B sütununda ki aynı hücreleri tesbit edip bir defa yazdırmak istiyorum. A sutununu baz alarak.

A sutununa göre B sutunundaki hücrelerin (aynı veya farklı hücreler) birer örneklerini yazrımak istiyorum.

işin içinden cıkamadıgım gibi anlatamadım da
örnek acıklayıcı olur umarım
yardımlarınız için şimdiden teşekkürler
örnek ektedir.

 

[Recep İpek]

Aşağıdaki kodları kullanabilirsiniz.

Sub Aktar()
'On Error Resume Next
Dim a, i, n, veri()
Set s1 = Sheets("Veri")
Set s2 = Sheets("Tablo")
'*******************************************
a = s1.Range("a2:b" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
            z = a(i, 1) & ":" & a(i, 2)
                If Not .exists(z) Then
                     n = n + 1
                    .Add z, n
                    veri(n, 1) = a(i, 1)
                    veri(n, 2) = a(i, 2)
                End If
            End If
        Next i
    End With
If n > 0 Then
s2.Range("a2:j1000").ClearContents
s2.Range("a2").Resize(n, 2).Value = veri
Else
MsgBox "Kayıt Bulunamadı.", vbInformation, "Bilgi"
End If
n = 0
'*******************************************
a = s2.Range("a2:b" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                If Not .exists(a(i, 1)) Then
                     n = n + 1
                    .Add a(i, 1), n
                    veri(n, 1) = a(i, 1)
                    veri(n, 2) = a(i, 2)
                Else
                    veri(.Item(a(i, 1)), 2) = veri(.Item(a(i, 1)), 2) & ", " & a(i, 2)
                End If
            End If
        Next i
    End With
If n > 0 Then
s2.Range("a2:j1000").ClearContents
s2.Range("a2").Resize(n, 2).Value = veri
Else
MsgBox "Kayıt Bulunamadı.", vbInformation, "Bilgi"
End If
'*******************************************
s2.[a2].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[bigevv]

Recep kardeşim cok teşekkür ediyorum


kodu örneğe ekleyip gonderdigin ayrıca teşekkür ediyorum
zira yeniyim ve bu kodları kullanmayı bilmiyorum

yüzyüze anlattıklarım dahi anlamakta zorlandılar yapmak istedigimi
bunu da belirtmek istedim

saygılar