Satır birleştirme

[blnturkek]

selam açıklama yaptığım satır birleştirme ektedir.

Kolay gelsin.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Ozet()
 
    Dim s(), a1, deg
    Dim i As Long, d As Object, j As Byte
 
    Sheets("Sayfa2").Select
    Cells.Clear
 
    Set d = CreateObject("Scripting.Dictionary")
 
    With Sheets("Sayfa1")
        For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            deg = .Cells(i, "B") & "|" & .Cells(i, "C")
            If Not d.exists(deg) Then
                ReDim s(1 To 12)
                For j = 1 To 12
                    s(j) = .Cells(i, j)
                Next j
                d.Add deg, s
            Else
                s = d.Item(deg)
                s(7) = s(7) & "," & .Cells(i, "G")
                s(8) = s(8) & "," & .Cells(i, "H")
                s(10) = s(10) + .Cells(i, "J")
                s(11) = s(11) + .Cells(i, "K")
                s(12) = s(12) + .Cells(i, "L")
                d.Item(deg) = s
            End If
        Next i
    End With
 
    a1 = d.items
 
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 1 To 12
            Cells(i + 1, j) = s(j)
        Next j
    Next i
 
    Set d = Nothing
 
End Sub

.

 

[blnturkek]

ilginiz için ALLAH razı olsun.

Makro olduda. birleştirme örnekte yaptığım gibi olmadı. tek fatura çift almış. sanki iki kere yapmış gibi

Fatura nosu ortak değer ve tarih ortak değer. Aynı fatura nosu ve tarih eşit olan satırlar birleşmesni istiyorum.

 

[Ömer]

Kodu çalıştırın olmayanları işaretleyip, nedenlerini açıkladıktan sonra dosyayı o haliyle ekleyin.

 

[blnturkek]

açıklama dosyanın içerisine yapılmıştır.

 

[Ömer]

Bir sorun yok, istedikleriniz dosyada oluyor. Yalnız, eklediğiniz dosyanın Sayfa1 deki 10.satırdan sonrasını yani "olmasını istediğim şekil" olarak adlandırdığınız bölümü silmemişsiniz. Silmediğiniz için doğal olarak veriler çift gelmektedir. Bu bölümü silerseniz istediğinizin olduğunu görebilirsiniz.

.

 

[blnturkek]

ALLAH razı olsun. Tamam anladım.

 

[blnturkek]

Selam a.

ustad bazı sütünlarda ekleme yapınca sizin verdiğiniz makronun bazı yerlerini değiştirim dedim olmadı. Yardımınız bekliyorum.

 

[Ömer]

Bu şekilde deneyin.

Sub Ozet()
 
    Dim s(), a1, deg
    Dim i As Long, d As Object, j As Byte
 
    Application.ScreenUpdating = False
    Sheets("Sayfa2").Select
    Cells.Clear
    
    Set d = CreateObject("Scripting.Dictionary")
 
    With Sheets("Sayfa1")
        For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
            deg = .Cells(i, "B") & "|" & .Cells(i, "C")
            If Not d.exists(deg) Then
                ReDim s(1 To 12)
                For j = 1 To 12
                    s(j) = .Cells(i, j)
                    s(9) = .Cells(i, "I") & " " & .Cells(i, "J")
                Next j
                d.Add deg, s
            Else
                s = d.Item(deg)
                s(8) = s(8) & "," & .Cells(i, "H")
                s(9) = s(9) & "," & .Cells(i, "I") & .Cells(i, "J")
                s(11) = s(11) + .Cells(i, "K")
                s(12) = s(12) + .Cells(i, "L")
                d.Item(deg) = s
            End If
        Next i
    End With
 
    a1 = d.items
 
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 1 To 12
            If j <> 10 Then
                Cells(i + 1, j) = s(j)
            End If
        Next j
    Next i
    
    Columns(10).Delete
    Set d = Nothing
 
End Sub

.