aynı olanları başka bir sayda teke düşürüp toplasın.

[ASMET67]

Selamlar.
Excel dosyamda A ile p Sutunları arasında satır sayısı değişmekte olan ve genelde 15000 satırdan az olmayan mükerrer kayıtlardan oluşan bir listem var.
Bu listenin asutunundaki değerlere göre teke düşürsün ve teke düşürdüğü değerin N sutunun toplayarak Sayfa2 ye koplayasın.
Bunu macro ile nasıl yapabilrim.

 

[Recep İpek]

40-50 kayıttan oluşan bir örnek dosya ekleyebilirmisiniz?

 

[ASMET67]

öernek

Hocam öernek dosya ekte.
A sutunundaki değere göre sayfa ikide teke düşürerek A ile M arasını ve OP sutunu olduğu gibi kopyalacak N sutununu toplayıp kopyalacak.

 

[Korhan Ayhan]

Selamlar,

Bu işlem için makroya ihtiyacınız bence yok. En ideali eğer ihtiyacınızı karşılıyorsa ÖZET TABLO ile çözümdür. Ekte özet tablo ile yapılmış örnek dosyanızı incelermisiniz. Umarım faydası olur.

 

[ASMET67]

Hocam Öncelikle teşekkürler.
Hazırladığınız örnek istediğim gibi.
Yalnız ben Pivot table yaptığımda tüm satırlarda verileri göstermiyor. Verileri gruplayarak gösteriyor. Bunu rüm satırlarda gösterecek şekilde nasıl ayarlarız.

 

[Recep İpek]

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

Sub AktarTopla()
Dim a, i As Long, b(), n As Long
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
veri = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 15, 16)
Application.ScreenUpdating = False
With s1.Range("a2").CurrentRegion.Resize(, 16)
     a = .Value
     ReDim b(1 To UBound(a, 1), 1 To 16)
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
                n = n + 1
                .Add a(i, 1), n
                For Each s In veri
                    b(n, s) = a(i, s)
                Next
          End If
          b(.Item(a(i, 1)), 14) = b(.Item(a(i, 1)), 14) + a(i, 14)
     Next
End With
With s2.Range("a1")
     .CurrentRegion.Resize(, 16).ClearContents
     .Resize(n, 16).Value = b
End With
Application.ScreenUpdating = True
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub