Şarta Göre Birleştirme

[YASINT]

Arkadaşlar merhabalar
Benim yapmak istediğimi kısaca anlatayım. Fatura listemdeki mükerrer olarak yazan tarih, fat. no ve cari adlarını tek satırda fakat mal cinsini ise aynı faturadaki malzemeleri birleştirip yazdırmak istiyorum. Bu mümkün ise çok büyük bir yükten kurtulmuş olucağım. Çünkü her ay yaklaşık 2000 satırla 3-4 gün uğraşıyorum. Bu konuda yardımlarınızı çok rica ediyorum. Tşk.


Tarih Fat. No Cari Adı Mal Cinsi
15.05.2010 1505 Er-Bakır Bakır Tel
15.05.2010 1505 Er-Bakır Bakır Tel
15.05.2010 1505 Er-Bakır Bakır Tel
15.05.2010 1505 Er-Bakır Lehim Teli
25.05.2010 785 Akplas Kalsit
25.05.2010 785 Akplas PVC Toz

OLMASINI İSTEDİĞİM SONUÇ DOSYASINA
Tarih Fat. No Cari Adı Mal Cinsi
15.05.2010 1505 Er-Bakır Bakır Tel - Bakır Tel - Bakır Tel - Lehim Teli
25.05.2010 785 Akplas Kalsit - PVC Toz

 

[Korhan Ayhan]

Selamlar,

Bu tarz sorularınızı örnek dosya ile desteklerseniz bizler hazırlamak zorunda kalmayız. Umarım hazırladığım dosyadaki sütunlar sizinki ile aynıdır.

Ekteki örnek dosyayı incelermisiniz.

Kullanılan kod;

Option Explicit
 
Sub VERİLERİ_DÜZENLE()
    Dim X As Long, BUL As Range, ADRES As String
 
    Sheets("Sayfa2").Select
    Cells.Delete
 
    Sheets("Sayfa1").Columns("A:C").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("A1"), Unique:=True
    Range("D1") = "Mal Cinsi"
 
    For X = 2 To Range("A65536").End(3).Row
        Set BUL = Sheets("Sayfa1").Range("B:B").Find(Cells(X, "B"), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
            If Cells(X, "A") = Sheets("Sayfa1").Cells(BUL.Row, "A") And Cells(X, "C") = Sheets("Sayfa1").Cells(BUL.Row, "C") Then
                If Cells(X, "D") = Empty Then
                    Cells(X, "D") = Sheets("Sayfa1").Cells(BUL.Row, "D")
                Else
                    Cells(X, "D") = Cells(X, "D") & " - " & Sheets("Sayfa1").Cells(BUL.Row, "D")
                End If
            End If
            Set BUL = Sheets("Sayfa1").Range("B:B").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    Next
 
    With Range("A1:D1")
        .Font.Bold = True
        .Font.ColorIndex = 3
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
    End With
 
    Set BUL = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[YASINT]

Allah Razı Olsun Korhan Bey inanın beni her ay yaşadığım büyük bir sıkıntıdan kurtardınız. Çok teşekkür ederim.