Mukerrer olanları toplamak

[Eser Gökay]

Merhabalar

Sorum ektedir. İyi çalışmalar

 

[Merhum İdris SERDAR]

Merhabalar

Sorum ektedir. İyi çalışmalar

Dosyanız ekte.

.

 

[Eser Gökay]

teşekkür ederim sayın yurttas

 

[Recep İpek]

Alternatif olarak aşağıdaki kodları deneyebilirsiniz.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("kayıt")
Set s2 = Sheets("özet")
'*******************************************
a = s1.Range("a2:d" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 5)
'*******************************************
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        z = a(i, 1) & ":" & a(i, 2)
           If Not IsEmpty(z) Then
                 If Not .exists(z) Then
                    n = n + 1
                    .Add z, n
                    veri(n, 1) = n
                    veri(n, 2) = a(i, 1)
                    veri(n, 3) = a(i, 2)
                End If
                    veri(.Item(z), 4) = veri(.Item(z), 4) + a(i, 3)
                    veri(.Item(z), 5) = veri(.Item(z), 5) + a(i, 4)
            End If
    Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "e")).ClearContents
s2.[a2].Resize(n, 5).Value = veri
''*******************************************
s2.Select
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Eser Gökay]

Çok teşekkür ederim Recep bey