Özel Topla

[leonadies]

Merhaba Üstadlar;

Elimde basit bir dosya var Ürün adı, Adet ve Sipariş Numarası yazıyor. Bir Makro Yardımıyla bu karışık verileri toplatabiliyorum. Ancak aynı ürüne ait benzersiz sipariş numaralarını da yan yana virgül ile ayırıp toplam adet sütunun yanına atmak istiyorum. Yardımcı olabilirmisiniz?

Dosyam Ekte.

 

[Muzaffer Ali]

Merhaba.
Dosyadaki kodu aşağıdaki ile değiştirin.

Sub Hesapla()
    Sheets("liste").Select
    Range("K2:L100").Select 'temizle
    Selection.ClearContents
    Range("K1").Select
    Dim SayfaAdi_Kaynak As String
    Dim SayfaAdi_Hedef As String
    
    SayfaAdi_Hedef = "liste"
    SayfaAdi_Kaynak = "liste"
    Sheets(SayfaAdi_Kaynak).Select
    Sheets(SayfaAdi_Hedef).Range("k2").Consolidate Sources:=Array( _
        "'" & SayfaAdi_Kaynak & "'!R2C1:R100C2"), _
        Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
    Range("a1").Select
    
    Dim BakKaynak As Long
    Dim SayKaynak As Long
    Dim BakHedef As Long
    Dim SayHedef As Long
    SayKaynak = Sheets(SayfaAdi_Hedef).Cells(Rows.Count, "A").End(3).Row
    SayHedef = Sheets(SayfaAdi_Hedef).Cells(Rows.Count, "K").End(3).Row
    For BakHedef = 2 To SayHedef
        For BakKaynak = 2 To SayKaynak
            If Sheets(SayfaAdi_Hedef).Cells(BakHedef, "K") = Sheets(SayfaAdi_Kaynak).Cells(BakKaynak, "A") Then
                If Sheets(SayfaAdi_Hedef).Cells(BakHedef, "M") = "" Then
                    Sheets(SayfaAdi_Hedef).Cells(BakHedef, "M") = Sheets(SayfaAdi_Kaynak).Cells(BakKaynak, "C")
                Else
                    Sheets(SayfaAdi_Hedef).Cells(BakHedef, "M") = Sheets(SayfaAdi_Hedef).Cells(BakHedef, "M") & ", " & Sheets(SayfaAdi_Kaynak).Cells(BakKaynak, "C")
                End If
            End If
        Next
    Next
End Sub

 

[leonadies]

Bu ne hız Süper. Ellerinize Sağlık üstadım

 

[muygun]

Merhaba;
Alternatif olsun. (benzersiz sipariş numaralarını da yan yana)
Deneyin.
İyi çalışmalar.

Sub Hesapla()
Range("k2:m65536").ClearContents
For i = 2 To Range("A65536").End(xlUp).Row
If WorksheetFunction.CountIf(Range("a2:a" & i), Cells(i, "a")) = 1 Then Cells(Range("k65536").End(xlUp).Row + 1, "k") = Cells(i, 1)
Next i
For i = 2 To Range("k65536").End(xlUp).Row
For k = 2 To Range("a65536").End(xlUp).Row
If Cells(i, "k") = Cells(k, 1) Then
Cells(i, "L") = Cells(i, "L") + Cells(k, 2)
If InStr(Cells(i, "m"), Cells(k, "c")) = 0 Then
If Cells(i, "m") <> "" Then
Cells(i, "m") = Cells(i, "m") & "," & Cells(k, 3)
End If
If Cells(i, "m") = "" Then
Cells(i, "m") = Cells(k, 3)
End If: End If: End If
Next k: Next i
End Sub