mükerrer sil ve toplama

[KAYA212]

Merhaba,
Ekteki listede 1.sayfadaki verileri 2. sayfada mükerrerleri silip(kodları teke düşürüp) toplam adetlerini saydırmak istiyorum.

Konu hakkında yardımlarınızı rica ediyorum.
sayğılarımla

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Topla()
 
    Dim d As Object, i As Long, s, a1, a2, deg As String
 
    Set d = CreateObject("Scripting.Dictionary")
 
    Application.ScreenUpdating = False
    Sheets("[COLOR="Red"]TÜM KODLAR 1. sayfa[/COLOR]").Select
 
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
       deg = Cells(i, "C")
       If Not d.exists(deg) Then
           s = Cells(i, "D")
           d.Add deg, s
       Else
           s = d.Item(deg)
           s = s + Cells(i, "D")
           d.Item(deg) = s
       End If
    Next i
 
    Sheets("[COLOR="red"]MÜKERRER SİL VE SAY 2. sayfa[/COLOR]").Select
    Range("B[COLOR="Red"]3[/COLOR]:D" & Rows.Count).ClearContents
    
    a1 = d.keys: a2 = d.items
    For i = 0 To d.Count - 1
        Cells(i + [COLOR="red"]3[/COLOR], "B") = i + 1
        Cells(i +[COLOR="red"] 3[/COLOR], "C") = a1(i)
        Cells(i + [COLOR="red"]3[/COLOR], "D") = a2(i)
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[Orion1]

Alternatif.

Option Base 1
Sub teke59()
Dim sh As Worksheet, sat As Long, liste(), z As Object
Dim i As Long
Sheets("MÜKERRER SİL VE SAY 2. sayfa").Select
Range("B3:D" & Rows.Count).ClearContents
Set sh = Sheets("TÜM KODLAR 1. sayfa")
liste = sh.Range("C2:D" & sh.Cells(Rows.Count, "C").End(xlUp).Row).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add liste(i, 1), n
    Else
        z.Item(liste(i, 1)) = z.Item(liste(i, 1)) + liste(i, 2)
    End If
Next i
Erase liste
Range("C3").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
For i = 3 To z.Count + 2
    Cells(i, "B").Value = i - 2
Next i
MsgBox "İşlem tamamlnadı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[jambow]

evet ikiside oldu teşekkürler