Tekrar Eden Fatura Numaralarını Tek Satırda Toplama

[renaksk]

Merhaba. Makro bilgim yok o yüzden sizden yardım rica ediyorum.

Ekteki dosyadaki sayfa 1 deki verilerin aynı fatura numarasına sahip olanların sayfa 2deki gibi toplamasını nasıl yapabilirim. Forumda benzer konular mevcut ancak toplamda tek ürün adı alınmış. Dosyamda ise ürün adı ve miktar alanları virgülle ayrılmış olarak yan yana yazılması gerekiyor. Şimdiden teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long, sn As Long, x As Long
Dim s As Object
Dim ayr As String

Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("Sayfa2")
Set s = CreateObject("Scripting.Dictionary")

ayr = "; "
sn = s1.Cells(Rows.Count, "B").End(3).Row
ReDim dz(1 To sn, 1 To 10)

For a = 2 To sn
    If s.exists(s1.Cells(a, "B").Value) Then
        x = s(s1.Cells(a, "B").Value)
        If InStr(1, dz(x, 5) & ayr, s1.Cells(a, "E") & ayr) = 0 Then
            dz(x, 5) = dz(x, 5) & ayr & s1.Cells(a, "E")
            dz(x, 6) = dz(x, 6) & ayr & Format(WorksheetFunction.SumIfs(s1.Range("F2:F" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"), s1.Range("E2:E" & sn), s1.Cells(a, "E")), "0.00")
            If InStr(1, dz(x, 8) & ayr, s1.Cells(a, "I") & ayr) = 0 Then dz(x, 8) = dz(x, 8) & ayr & s1.Cells(a, "I")
        End If
    Else
        x = s.Count + 1
        s.Add s1.Cells(a, "B").Value, x
        dz(x, 1) = s1.Cells(a, "A")
        dz(x, 2) = s1.Cells(a, "B")
        dz(x, 3) = s1.Cells(a, "C")
        dz(x, 4) = s1.Cells(a, "D")
        dz(x, 5) = s1.Cells(a, "E")
        dz(x, 6) = WorksheetFunction.SumIfs(s1.Range("F2:F" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"), s1.Range("E2:E" & sn), s1.Cells(a, "E"))
        dz(x, 7) = WorksheetFunction.SumIfs(s1.Range("H2:H" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"))
        dz(x, 8) = s1.Cells(a, "I")
        dz(x, 9) = WorksheetFunction.SumIfs(s1.Range("J2:J" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"))
        dz(x, 10) = s1.Cells(a, "K")
    End If
Next
s2.Range("A2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

 

[renaksk]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long, sn As Long, x As Long
Dim s As Object
Dim ayr As String

Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("Sayfa2")
Set s = CreateObject("Scripting.Dictionary")

ayr = "; "
sn = s1.Cells(Rows.Count, "B").End(3).Row
ReDim dz(1 To sn, 1 To 10)

For a = 2 To sn
    If s.exists(s1.Cells(a, "B").Value) Then
        x = s(s1.Cells(a, "B").Value)
        If InStr(1, dz(x, 5) & ayr, s1.Cells(a, "E") & ayr) = 0 Then
            dz(x, 5) = dz(x, 5) & ayr & s1.Cells(a, "E")
            dz(x, 6) = dz(x, 6) & ayr & Format(WorksheetFunction.SumIfs(s1.Range("F2:F" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"), s1.Range("E2:E" & sn), s1.Cells(a, "E")), "0.00")
            If InStr(1, dz(x, 8) & ayr, s1.Cells(a, "I") & ayr) = 0 Then dz(x, 8) = dz(x, 8) & ayr & s1.Cells(a, "I")
        End If
    Else
        x = s.Count + 1
        s.Add s1.Cells(a, "B").Value, x
        dz(x, 1) = s1.Cells(a, "A")
        dz(x, 2) = s1.Cells(a, "B")
        dz(x, 3) = s1.Cells(a, "C")
        dz(x, 4) = s1.Cells(a, "D")
        dz(x, 5) = s1.Cells(a, "E")
        dz(x, 6) = WorksheetFunction.SumIfs(s1.Range("F2:F" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"), s1.Range("E2:E" & sn), s1.Cells(a, "E"))
        dz(x, 7) = WorksheetFunction.SumIfs(s1.Range("H2:H" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"))
        dz(x, 8) = s1.Cells(a, "I")
        dz(x, 9) = WorksheetFunction.SumIfs(s1.Range("J2:J" & sn), s1.Range("B2:B" & sn), s1.Cells(a, "B"))
        dz(x, 10) = s1.Cells(a, "K")
    End If
Next
s2.Range("A2").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

Çok teşekkür ederim. Oldu. Sağolun

 

[ÖmerBey]

Siz de sağ olun.
İyi çalışmalar...