Aynı isimleri toplasın Tek Satırda Yazsın.

[YASINT]

Merhaba arkadaşlar benim elimde yaklaşık 2000 satırlık bir tablo var ve de benim yükleme listesi yapabilmem için bu satrlarad aynı firmadan alınan malzemelerin tek satırda gösterilip fatura adedini yazmam gerekiyor. Tam manasıyla anlatabilmem içinde ekte küçük bir örnek gönderiyorum. Sizden ricam bu tabloyu en kısa sürede nasıl yapabilirim. Ben daha önce Alttoplam alarak yapıyorum vede bu benim epey bir zamanımı alıyor. Bunu makro yoluyla kestirme yoldan nasıl yapabilirim. Yardımlarınızı bekliyorum teşekkürler.

 

[AS3434]

Sayın YASINT

Ekli Dosyayı inceleyin kendinize uyarlayın.

 

[YASINT]

çok teşekkür ederim Sayın As3434

 

[Korhan Ayhan]

Selamlar,

Sn. AS3434 size formülle çözümü sunmuş. Alternatif olarak makrolu çözümde ekteki dosyadadır. Umarım faydası olur.

 

[Recep İpek]

Bir alternatifde benden olsun...

Sub AktarTopla()
Dim a, i As Long, b(), n As Long
Set s1 = Sheets("Ham Tablo")
Set s2 = Sheets("Sonuc")
Application.ScreenUpdating = False
s2.Range("a2:d100").ClearContents
'*******************************************************
With s1.Range("a2").CurrentRegion.Resize(, 4)
     a = .Value
     ReDim b(1 To UBound(a, 1), 1 To 5)
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 3)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 2)
                b(n, 3) = a(i, 3)
                b(n, 5) = 1
                .Add a(i, 3), n
            Else
                b(.Item(a(i, 3)), 5) = b(.Item(a(i, 3)), 5) + 1
            End If
                b(.Item(a(i, 3)), 4) = b(.Item(a(i, 3)), 4) + a(i, 4)
        Next i
        For j = 1 To n
            If b(j, 5) > 1 Then
                   b(j, 1) = b(j, 5) & " Adet Fatura"
                   b(j, 2) = Empty
            End If
        Next j
End With
Range("a2").Resize(n, 4).Value = b
'*******************************************************
Application.ScreenUpdating = True
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub