iki kritere göre toplam alma

[metinavci23]

arkadaşlar merhaba
ekteki dosyanın makrosunu buradan bulmuştum.makroyu iki kritere göte toplam almasını istedim ama yapamadım.yardımcı olursanız sevinirim.herkese kolay gelsin.dosya ektedir

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub AktarSay()
Dim a, i, n, b()
Set s1 = Sheets("data")
Set s2 = Sheets("Toplama")
'*******************************************
a = s1.Range("b2:d" & s1.[b65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 4)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
           If Not IsEmpty(a(i, 1)) Then
                z = a(i, 1) & ":" & a(i, 2)
                If Not .exists(z) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 1)
                    b(n, 3) = a(i, 2)
                    .Add z, n
                End If
                    b(.Item(z), 4) = b(.Item(z), 4) + a(i, 3)
            End If
    Next
End With
'*******************************************
son = s2.[e65536].End(3).Row + 1
s2.Range(Cells(2, "e"), Cells(son, "h")).ClearContents
s2.[e2].Resize(n, 4).Value = b
'*******************************************
MsgBox "Bitti"
s2.Select
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub topla()
Dim i As Long, k As Long, j As Byte
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Toplama")
k = 2
s2.Range("F2:H65536").ClearContents
Application.ScreenUpdating = False
For i = 2 To s1.Cells(65536, "B").End(xlUp).Row
    For k = 2 To s2.Cells(65536, "F").End(xlUp).Row
        If s1.Cells(i, "B").Value = s2.Cells(k, "F").Value And _
        s1.Cells(i, "C").Value = s2.Cells(k, "G").Value Then
            s2.Cells(k, "H").Value = s2.Cells(k, "H").Value + s1.Cells(i, "D").Value
            GoTo atla
        End If
    Next k
    For j = 2 To 4
        s2.Cells(k, j + 4).Value = s1.Cells(i, j).Value
    Next j
atla:
Next i
Range("F2:H65536").Sort Range("F2"), 1
Application.ScreenUpdating = True
MsgBox "İşlem Bitti..!!"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[metinavci23]

cevap

teşekürler sayın Ripek ve sayın Orion 2.Ellerinize sağlık