Ürün sipariş numaralarını virgül ile birleştirmek

[gurayavci]

Merhaba

Örnek yüklediğim excel'de göreceğiniz üzere birleştirmek istediğim iki veri var.
Sayfa1'de Ürün numaraları ve Ürün sipariş numaraları olmak üzere iki sütun var. Bu sütunlarda Solda bulunan ürünlerin hangi sipariş numaralarında bulunduğunu araya virgül koyarak tek hücrede görmek istiyorum.

Örnek excelde yaşadığım sorun ; virgüllü şekilde sipariş numaralarını yanyana koyarken aynı sipariş numarası bir ürün için 2 satırda görünüyorsa sipariş numarasını iki defa yazdrıyor. Fakat benim o sipariş numarasını sadece 1 defa yazdırmam gerekiyor

Ürün kodu Sipariş kodu
111222--------75754
333111--------78954
111222 -------75754
111222 -------76654


Birleştir butonuna bastığımda
111222 numaralı ürünün karşısına 757574,757574,76654
şeklinde verileri yazıyor

1. ricam bu iki çıktıyı şu an aynı hücreye yapıyor ," 757574,757574,76654" bu çıktıyı tek başına bir hücrede göstermesini istiyorum
2. ricam " 757574,757574,76654" şu halde çıkarttığı sonucu " 757574,76654" bu şekilde çıkartmasını istiyorum, aynı sipariş numarası olduğunda ikinci defa virgül atıp yazmasın, bu sipariş numarasından 1 tane var olduğunu tespit edip 1 tane yazmasını istiyorum

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub My_Concatenate()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim My_Data As Variant, Son As Long
    Dim Dizi As Object, X As Long, Say As Long
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    S2.Cells.Clear
    S2.Range("A1:B1").Value = Array("ÜRÜN KODU", "SİPARİŞ NO")
    S2.Range("A1:B1").Font.Bold = True
    
    My_Data = S1.Range("A1").CurrentRegion.Value
    
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 2)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) <> "Ürün kodu" Then
            If Not Dizi.Exists(My_Data(X, 1)) Then
                Say = Say + 1
                Dizi.Add My_Data(X, 1), Say
                My_List(Say, 1) = My_Data(X, 1)
                My_List(Say, 2) = My_Data(X, 2)
            Else
                If Len(Replace(My_List(Dizi.Item(My_Data(X, 1)), 2), My_Data(X, 2), "")) = _
                    Len(My_List(Dizi.Item(My_Data(X, 1)), 2)) Then
                    My_List(Dizi.Item(My_Data(X, 1)), 2) = _
                    My_List(Dizi.Item(My_Data(X, 1)), 2) & ", " & My_Data(X, 2)
                End If
            End If
        End If
    Next
    
    S2.Range("A2").Resize(Say, 2) = My_List
    S2.Columns.AutoFit
    S2.Select
    
    Erase My_Data
    Erase My_List
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
        
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ziynettin]

Alternatif,

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = s1.Range("A" & Rows.Count).End(3).Row
a = s1.Range("A1:B" & son).Value

Set dz = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")

ReDim b(1 To UBound(a), 1 To 2)

For i = 1 To UBound(a)
    v = a(i, 1) & "|" & a(i, 2)
    If Not dz.exists(v) Then
        dz(v) = ""
        k = a(i, 1)
        If Not dc.exists(k) Then
            dc(k) = dc.Count + 1
            s = dc.Count
            b(s, 1) = k
            b(s, 2) = a(i, 2)
        Else
            s = dc(k)
            b(s, 2) = b(s, 2) & ", " & a(i, 2)
        End If
    End If
Next i

Application.ScreenUpdating = False

With s2.Range("A:B")
    .ClearContents
    .ClearFormats
End With

With s2.[A1].Resize(dc.Count, 2)
    .NumberFormat = "@"
    .Value = b
    .Columns.AutoFit
    .Borders.Color = rgbSilver
End With

Application.ScreenUpdating = True

MsgBox "İşlem bitti.", vbInformation
End Sub

 

[gurayavci]

Deneyiniz.

Option Explicit

Sub My_Concatenate()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim My_Data As Variant, Son As Long
    Dim Dizi As Object, X As Long, Say As Long
   
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
   
    S2.Cells.Clear
    S2.Range("A1:B1").Value = Array("ÜRÜN KODU", "SİPARİŞ NO")
    S2.Range("A1:B1").Font.Bold = True
   
    My_Data = S1.Range("A1").CurrentRegion.Value
   
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 2)
   
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) <> "Ürün kodu" Then
            If Not Dizi.Exists(My_Data(X, 1)) Then
                Say = Say + 1
                Dizi.Add My_Data(X, 1), Say
                My_List(Say, 1) = My_Data(X, 1)
                My_List(Say, 2) = My_Data(X, 2)
            Else
                If Len(Replace(My_List(Dizi.Item(My_Data(X, 1)), 2), My_Data(X, 2), "")) = _
                    Len(My_List(Dizi.Item(My_Data(X, 1)), 2)) Then
                    My_List(Dizi.Item(My_Data(X, 1)), 2) = _
                    My_List(Dizi.Item(My_Data(X, 1)), 2) & ", " & My_Data(X, 2)
                End If
            End If
        End If
    Next
   
    S2.Range("A2").Resize(Say, 2) = My_List
    S2.Columns.AutoFit
    S2.Select
   
    Erase My_Data
    Erase My_List
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
       
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan bey çok teşekkür ederim, işime yaradı, sadece aktardığı sabit 08 ile başlayan numaraların başındaki sıfırları siliyordu, onuda sanıyorum Ziynettin bey düzeltmiş, Elinize sağlık

Alternatif,

Sub test()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = s1.Range("A" & Rows.Count).End(3).Row
a = s1.Range("A1:B" & son).Value

Set dz = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")

ReDim b(1 To UBound(a), 1 To 2)

For i = 1 To UBound(a)
    v = a(i, 1) & "|" & a(i, 2)
    If Not dz.exists(v) Then
        dz(v) = ""
        k = a(i, 1)
        If Not dc.exists(k) Then
            dc(k) = dc.Count + 1
            s = dc.Count
            b(s, 1) = k
            b(s, 2) = a(i, 2)
        Else
            s = dc(k)
            b(s, 2) = b(s, 2) & ", " & a(i, 2)
        End If
    End If
Next i

Application.ScreenUpdating = False

With s2.Range("A:B")
    .ClearContents
    .ClearFormats
End With

With s2.[A1].Resize(dc.Count, 2)
    .NumberFormat = "@"
    .Value = b
    .Columns.AutoFit
    .Borders.Color = rgbSilver
End With

Application.ScreenUpdating = True

MsgBox "İşlem bitti.", vbInformation
End Sub

Teşekkürler Ziynettin bey