Koşula Göre Hücreleri İçindeki Verileri Birleştirme

[hilmitaranci]

Merhabalar,

Ekte kdv iadesi için oluşturmaya çalıştığım tablonun bir örneği bulunmakta yaklaşık 12 sayfa ve her sayfada 11 000 satır veri bulunuyor.

Fatura numarası aynı olan kayıtların açıklamalarını tek bir hücrede birleştirip, aynı fatura numarasına sahip tutarları toplamaya çalışıyorum.

Siteden ve bir kaç yerden bulduğum kaynaklar pek işime yaramadı.

Yardımcı olabilirseniz çok sevinirim.


http://s6.dosya.tc/server9/er428e/levent.xls.html

 

[askm]

Aşağıdaki kodları kullanabilirsiniz.

Sub askm_Birlestir()
Dim str As Integer
Dim SonSat1, SonSat2 As Long
Dim top As Long
Range("K2:M65000").ClearContents
SonSat1 = Range("A65536").End(xlUp).Row
Dim kelime As String
Application.ScreenUpdating = False
Range("A1:A" & SonSat1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "A2:A" & SonSat1), CopyToRange:=Range("U1"), Unique:=True

SonSat2 = Range("U65536").End(xlUp).Row
str = 2
For i = 2 To SonSat2
    Cells(str, "K") = Cells(i, "U")
    kelime = Empty
        For k = 2 To SonSat1
            If Cells(str, "K") = Cells(k, "A") Then
                kelime = kelime & "," & Cells(k, "B")
                top = top + Cells(k, "C")
            End If
            
        Next k
    Cells(str, "L") = Trim(Mid(kelime, 2, Len(kelime)))
    Cells(str, "M") = top
    str = str + 1
Next i
Range("U1:U65000").ClearContents
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı...", vbInformation, "ASKM"
End Sub

 

[hilmitaranci]

Aşağıdaki kodları kullanabilirsiniz.

Sub askm_Birlestir()
Dim str As Integer
Dim SonSat1, SonSat2 As Long
Dim top As Long
Range("K2:M65000").ClearContents
SonSat1 = Range("A65536").End(xlUp).Row
Dim kelime As String
Application.ScreenUpdating = False
Range("A1:A" & SonSat1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "A2:A" & SonSat1), CopyToRange:=Range("U1"), Unique:=True

SonSat2 = Range("U65536").End(xlUp).Row
str = 2
For i = 2 To SonSat2
    Cells(str, "K") = Cells(i, "U")
    kelime = Empty
        For k = 2 To SonSat1
            If Cells(str, "K") = Cells(k, "A") Then
                kelime = kelime & "," & Cells(k, "B")
                top = top + Cells(k, "C")
            End If
            
        Next k
    Cells(str, "L") = Trim(Mid(kelime, 2, Len(kelime)))
    Cells(str, "M") = top
    str = str + 1
Next i
Range("U1:U65000").ClearContents
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı...", vbInformation, "ASKM"
End Sub

Ustam ellerine kollarına sağlık inanılmaz güzel bir çalışma olmuş. teşekkür ederim.

Fakat toplama işlemini yaparken sadece fatura numaralarını gruplayıp toplamıyor, bir sonraki satırda üstüne ilave ederek gidiyor.

Bunu nasıl düzeltebilirim.


aşağıdaki gibi ekleme yapınca düzeldi. tekrardan çok teşekkür ederim.

Next k
Cells(str, "L") = Trim(Mid(kelime, 2, Len(kelime)))
Cells(str, "M") = top
str = str + 1
top = 0

Next i

 

[askm]

kelime = Empty den sonra olmak üzere top=empty yazarsanız olur. Gözden kaçmış.k.b.