iki sutundaki mükererlere göre şartlı toplatma

[numan şamil]

Merhaba arkadaşlar makrolarla uzun zamandır uyraşmadığımdan unutmuşum
Ekli örnekte gerekli açıklama yapılmıştır

 

[mustafa1205]

Formül ile işinize yarar ise bir deneyiniz

 

[numan şamil]

Malesef makro ile olması gerekiyor

 

[tahsinanarat]

Sn. @numan şamil
Kodlar Sn. @Korhan Ayhan hocama ait kodlardır. A ve B sutunu aynı olanları sayfa2 ye C sutununu toplayarak aktarır.

Sub AktarTopla2()
Dim a, i As Long, b(), n As Long
Set S1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
a = S1.Range("a2:d5000").Value
ReDim b(1 To UBound(a, 1), 1 To 4)
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a, 1)
     Z = a(i, 1) & " " & a(i, 2) '(i, 2 ikinci kolan, 3üçüncü, artıkça çoağalıyor)
          If Not .exists(Z) Then
               n = n + 1
               .Add (Z), n
               b(n, 1) = a(i, 1)
               b(n, 2) = a(i, 2)
               End If
          b(.Item(Z), 3) = b(.Item(Z), 3) + a(i, 3)
          Next
End With
s2.Range("a2:c5000").ClearContents
s2.Range("a2").Resize(n, 4).Value = b
MsgBox "Bitti"
[a1].Select
Set S1 = Nothing
Set s2 = Nothing
End Sub

 

[Korhan Ayhan]

Merhaba,

Bu değişken yazım tekniğini genelde Ziynettin bey kullanır. Hak geçmesin..

 

[numan şamil]

Sn Tahsinanarat teşekkürler
Korhan Hocam sizin tekniğinizle
örneğin :
If WorksheetFunction.CountIf
WorksheetFunction.SumIf
ile mümkün mü ?
Altarnatif kod yazılabilinir mi?

 

[Korhan Ayhan]

Merhaba,

Alternatifler elbette yazılabilir. Zaten defalarca benzer sorular cevaplandı. Forumun arşivinde bulunuyor. Burda beklenen performans önemlidir. Önerilen çözüm en hızlı tekniklerden birisidir.

Alternatif olarak hızıda gözeterek aşağıdaki teknikler kullanılabilir

1-Adodb
2-Makro ile özet tablo
3-Collection nesnesi kullanılarak çözüm üretilebilir.
4-System.Collections.ArrayList nesnesi kullanılarak çözüm üretilebilir.
5-Makro ile Yinelenenleri Kaldır uygulanıp benzersiz verler listelendikten sonra toplamları alınabilir.
6-Makro ile Gelişmiş Filtre uygulanıp benzersiz veriler listelendikten sonra toplamları alınabilir.

 

[numan şamil]

Merhaba Korhan Hocam
Anlamak için soruyorum

Sub AktarTopla()
Dim S1 As Worksheet, S2 As Worksheet
Dim a As Variant
Dim i As Long, b(), n As Long
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
son = S1.Cells(Rows.Count, "A").End(xlUp).Row
    a = S1.Range("A2:D" & son).Value
ReDim b(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) '(i, 2 ikinci kolan, 3üçüncü, artıkça çoağalıyor)
          If Not .exists(Z) Then
               n = n + 1
               .Add (Z), n
               b(n, 1) = a(i, 1)
               b(n, 2) = a(i, 2)
               b(n, 3) = a(i, 3)
               b(n, 4) = a(i, 4)
               End If
          b(.Item(Z), 5) = b(.Item(Z), 5) + a(i, 5)
          Next
End With
S2.Range("A2:E" & Rows.Count).ClearContents
S2.Range("a2").Resize(n, 5).Value = b
MsgBox "Bitti"
[a1].Select
Set S1 = Nothing
Set S2 = Nothing
End Sub

Yukarıdaki kodları
A ve b sutunu yerine
Q ve T sutunlarında mükerrerleri baz alırsak
nasıl değiştirebiliriz
Ekli örnekteki gibi

 

[Korhan Ayhan]

Şu iki satırı revize etmeniz yeterli olacaktır. Kalın fontla belirttiğim adresleri revize etmelisiniz.

son = S1.Cells(Rows.Count, "A").End(xlUp).Row
a = S1.Range("A2:D" & son).Value

 

[veyselemre]

Yukarıdaki kodları
A ve b sutunu yerine
Q ve T sutunlarında mükerrerleri baz alırsak
nasıl değiştirebiliriz
Ekli örnekteki gibi

Örnek olsun,

Sub test()

    Dim veri, say&, i&, krt$, sira&
    
    With Sheets("Sayfa1")
        veri = .Range("Q2:U" & .Cells(Rows.Count, "Q").End(3).Row).Value
    End With

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            krt = veri(i, 1) & "|" & veri(i, 2) & "|" & veri(i, 3) & "|" & veri(i, 4)
            If .exists(krt) Then
                sira = .Item(krt)
                veri(sira, 5) = veri(sira, 5) + veri(i, 5)
            Else
                say = say + 1
                veri(say, 1) = veri(i, 1)
                veri(say, 2) = veri(i, 2)
                veri(say, 3) = veri(i, 3)
                veri(say, 4) = veri(i, 4)
                veri(say, 5) = veri(i, 5)
                .Item(krt) = say
            End If
        Next i
    End With
    
    With Sheets("Sayfa2")
        .Range("A2:E" & Rows.Count).ClearContents
        .Range("A2").Resize(say, 5).Value = veri
    End With

End Sub

 

[numan şamil]

Sn; Korhan Ayhan,Veyselemre çok teşekkür ederim

 

[numan şamil]

Tekrardan merhabalar

b(.Item(Z), 5) = b(.Item(Z), 5) + a(i, 5)

8 nolu mesajdaki kodlarda bir sutun toplatılıyordu
Aynı şartlarda iki sutun toplatmak istersek kodlarda ne gibi değişiklik yapmamız gerekiyor

b(.Item(Z), 6) = b(.Item(Z), 6) + a(i, 6)

nasıl birleştirebiliriz

 

[numan şamil]

b(.Item(z), 5) = b(.Item(z), 5) + a(i, 5)
          b(.Item(z), 6) = b(.Item(z), 6) + a(i, 6)

Daha önce denediğimde hata vermişti
Şeklinde yapıldı Sorun çözüldü