Sayfa içerisinde aynı olan verilerin toplanması

[millis]

Sayın üstadlar; Bir sayfam var ve bu sayfa içerisinde birden çok veriler var ve bu verilerin E sütununda bulunan aynı rakkamların P sütununda bulunan rakkamları toplayım başka bir sayfada tek bir satırda göstermesini istiyorum. Bunu bir buton yardımı ile yapmak istiyorum. Acaba bu mümkünmü? Acil yardımlarınızı bekliyorum. Saygılarımla. Örnek dosyayı ekliyorum.

 

[veyselemre]

Sub Ozetle()
BAŞLAMA = Time
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s1.Select

s2.[A2:B65536].ClearContents

Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = TextCompare
    
    For x = 4 To [a65536].End(3).Row
        ekle = Cells(x, "E")
        sayi = Cells(x, "P")
        If dic.Exists(ekle) Then
            w = dic(ekle)
            dic(ekle) = w + sayi
        Else
            w = 1
            dic.Add ekle, sayi
        End If
    Next

dizi = dic.Keys
s2.Select

For x = 0 To UBound(dizi)
    Cells(x + 2, 1) = dizi(x)
Next
dizi = dic.Items
For x = 0 To UBound(dizi)
    Cells(x + 2, 2) = Format(dizi(x), "#,##0.00")
Next
[a1] = "No"
[b1] = "Toplam"
[A2:B65536].Sort Key1:=[a2], Order1:=xlAscending, Header:=xlGuess

BİTİŞ = Time

Application.ScreenUpdating = True
Erase dizi
Set dic = Nothing
MsgBox "İşlem süresi :  " & Format(BİTİŞ - BAŞLAMA, "hh:mm:ss.dd") & vbCrLf & "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Sub AKTAR()
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    S2.[A2:B65536].ClearContents
    S1.[E2:E65536].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.[AA1], Unique:=True
    S1.Range("AA3:AA" & S1.[AA65536].End(3).Row).Cut
    S2.Select
    [A2].Select
    ActiveSheet.Paste
    S1.[AA:AA].Delete Shift:=xlToLeft
    [B2].Formula = "=SUMIF(Sayfa1!E$4:E$65536,A2,Sayfa1!P$4:P$65536)"
    [B2].AutoFill Destination:=Range("B2:B" & S2.[A65536].End(3).Row), Type:=xlFillDefault
    [A1].Select
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "VERİLER AKTARILMIŞTIR.", vbInformation
End Sub

 

[millis]

ilginize teşekkür ederim

Selamlar,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Sub AKTAR()
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    S2.[A2:B65536].ClearContents
    S1.[E2:E65536].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.[AA1], Unique:=True
    S1.Range("AA3:AA" & S1.[AA65536].End(3).Row).Cut
    S2.Select
    [A2].Select
    ActiveSheet.Paste
    S1.[AA:AA].Delete Shift:=xlToLeft
    [B2].Formula = "=SUMIF(Sayfa1!E$4:E$65536,A2,Sayfa1!P$4:P$65536)"
    [B2].AutoFill Destination:=Range("B2:B" & S2.[A65536].End(3).Row), Type:=xlFillDefault
    [A1].Select
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "VERİLER AKTARILMIŞTIR.", vbInformation
End Sub

Sayın Üstadlarım, ilgilerinizeden dolayı çok çok teşekkür ederim. Böyle bir forum sayfası oluşturmakla ne kadar faydalı işler yaptığınızı biliyormusunuz( eminim biliyorsunuzdur ) ve en değerli hazine olan bilgiyi her hangi bir karşılık beklemeden sunmak, ne kadar değerli insanlar olduğunuzu gösteriyor. Sizlere bu paylaşımlarınızdan dolayı yeniden çok çok teşekkür ederim. Umarım herşey gönlünüzce olur.