kayıt Toplama

[selcuk_c]

Arkadaşlar ,


Listemde aynı isimli girişler ve karşılarında adetleri var.
İstediğim isimleri aynı olan satılardaki adetleri toplayıp sayfa-2 de bunları listelemek yapmak istediğim dosya ektedir. Yardımlarınızı bekliyorum. Teşekkürler

 

[N.Ziya Hiçdurmaz]

Yanıt

Sub TOPLA()
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
For SUT = 1 To S1.[A65536].End(3).Row
If WorksheetFunction.CountIf(S1.Range("A1:A" & SUT), S1.Range("A" & SUT)) = 1 Then
S = S + 1
S2.Range("A" & S) = S1.Range("A" & SUT).Value
End If
Next
S2.[B2:B100].Clear
For SUT1 = 2 To S1.[A65536].End(3).Row
For SUT2 = 2 To S2.[A65536].End(3).Row
If S2.Range("A" & SUT2) = S1.Range("A" & SUT1) Then
S2.Range("B" & SUT2) = S2.Range("B" & SUT2) + S1.Range("B" & SUT1)
End If
Next
Next
End Sub

 

[selcuk_c]

çok teşekkürler minnettarımmm...

 

[N.Ziya Hiçdurmaz]

Bişey değil.

 

[Recep İpek]

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

Sub AktarTopla()
Dim a, i, n, k, b()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a2:b" & s1.[a65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 1)
                    .Add a(i, 1), n
                End If
                    b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 2)
            End If
    Next
End With
s2.Range("a2:c100").ClearContents
s2.[a2].Resize(n, 3).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub