• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Mükerrer Verileri Toplama.

C

ccuneyt13

Altın Üye
Katılım
20 Ocak 2011
Mesajlar
478
Excel Vers. ve Dili
Office 365 Türkçe (64 bit)
Merhabalar,
Ham verilerin olduğu bir raporum var ve içindeki bilgileri ÖZEL tablo şeçeneği sayesinde mükerrer olanları birleştiriyorum ve topluyorum ama bu çok zamanımı alıyor. Binlerce aboneye ait bu bilgileri makro marifetiyle birleştirip toplam aldırmak istiyorum. Örnek tabloda detaylı izah etmeye çalıştım.


Not: Bu konuyla ilgili çok fazla konu açılmış ama herkesin örnekleri kendi tablosuna göre olduğu için benim gibi makro bilgisi kopyala yapıştırdan öteye gidemeyleri için kendi tabloma uyarlamak biraz karmaşık ve zor. O yüzden açmış olduğum konu başlığı için affınıza sığınıyorum.

Saygılar.
 

Ekli dosyalar

Merhaba,


Ekteki kodları test edermisiniz.

Kod: 
Sub Toplafarklı()
 Set s1 = Sheets("liste")
 Set s2 = Sheets("data")

s1.Range("A2:M65536").ClearContents

For i = 2 To s2.Range("D65536").End(3).Row

kişi = s2.Cells(i, 4).Value
Adet = WorksheetFunction.CountIf(s1.Range("D2:D" & s1.Range("D65536").End(3).Row), kişi)
Adet2 = WorksheetFunction.CountIf(s2.Range("D2:D" & s2.Range("D65536").End(3).Row), kişi)
Bakiye1 = WorksheetFunction.SumIf(s2.Range("D:D"), kişi, s2.Range("G:G"))
Bakiye2 = WorksheetFunction.SumIf(s2.Range("D:D"), kişi, s2.Range("F:F"))
Bakiye3 = WorksheetFunction.SumIf(s2.Range("D:D"), kişi, s2.Range("H:H"))
Bakiye4 = WorksheetFunction.SumIf(s2.Range("D:D"), kişi, s2.Range("I:I"))
Bakiye5 = WorksheetFunction.SumIf(s2.Range("D:D"), kişi, s2.Range("J:J"))

If Adet = 0 Then
Sonstr = s1.Range("B65536").End(3).Row + 1
s1.Cells(Sonstr, 1).Value = s2.Cells(i, 1).Value
s1.Cells(Sonstr, 2).Value = s2.Cells(i, 2).Value
s1.Cells(Sonstr, 3).Value = s2.Cells(i, 3).Value
s1.Cells(Sonstr, 4).Value = s2.Cells(i, 4).Value
s1.Cells(Sonstr, 5).Value = Adet2
s1.Cells(Sonstr, 6).Value = Bakiye2
s1.Cells(Sonstr, 7).Value = Bakiye1
s1.Cells(Sonstr, 8).Value = Bakiye3
s1.Cells(Sonstr, 9).Value = Bakiye4
s1.Cells(Sonstr, 10).Value = Bakiye5
s1.Cells(Sonstr, 11).Value = s2.Cells(i, 11).Value
s1.Cells(Sonstr, 12).Value = s2.Cells(i, 12).Value
s1.Cells(Sonstr, 13).Value = s2.Cells(i, 13).Value

End If
Next
End Sub
 
Hüseyin bey öncelikle elinize sağlık istediğim tam olarak buydu. Lakin bi sorun var ve sorunun sebebini buldum fakat çözümünüde sizde istirham edeceğim.

Sistemsel olarak aldığım raporda Adı Soyadı ( D sütünü)'nda Boş Gelen Hücreler var. Bu boş değerleri saymıyor makro.

Birde şu var sanırım bu makro sadece ismi aynı olanları topluyor gibi geldi bana. Kriter A ve B sütünları olması gerekiyor. Çünkü Aynı isime sahip ama farklı kişlerin borçlarını tek bir kişi gibi değerlendirmesini istemediğim için A ve B aynı ise topla ve birleştir yapmasını istiyorum.

Aynı İşletme Numarası Altında, aynı abone numarasının mükerrer olma ihtimali yok, ama aynı işletme numarası altında aynı isim ve soyisimde bir çok farklı kişi olma ihtimali var.

Biraz uzun oldu kusura bakmayın.
 
Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub ÖZET_TABLO()
    Dim S1 As Worksheet, S2 As Worksheet, WF As WorksheetFunction
    Dim X As Long, Satır As Long, Say As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("data")
    Set S2 = Sheets("liste")
    Set WF = WorksheetFunction
    
    S2.Range("A2:M" & Rows.Count).ClearContents
    Satır = 2
    S1.Range("R2") = "=CONCATENATE(A2,""#"",B2)"
    S1.Range("R2").AutoFill Destination:=S1.Range("R2:R" & S1.Cells(Rows.Count, 1).End(3).Row)
    S1.Range("R2:R" & S1.Cells(Rows.Count, 1).End(3).Row).Value = S1.Range("R2:R" & S1.Cells(Rows.Count, 1).End(3).Row).Value
    
    For X = 2 To S1.Cells(Rows.Count, "R").End(3).Row
        Say = WF.CountIf(S1.Range("R2:R" & X), S1.Cells(X, "R"))
        If Say = 1 Then
            S2.Cells(Satır, 1) = S1.Cells(X, 1)
            S2.Cells(Satır, 2) = S1.Cells(X, 2)
            S2.Cells(Satır, 3) = S1.Cells(X, 3)
            S2.Cells(Satır, 4) = S1.Cells(X, 4)
            S2.Cells(Satır, 5) = WF.CountIf(S1.Range("R:R"), S1.Cells(X, "R"))
            S2.Cells(Satır, 6) = WF.SumIf(S1.Range("R:R"), S1.Cells(X, "R"), S1.Range("F:F"))
            S2.Cells(Satır, 7) = WF.SumIf(S1.Range("R:R"), S1.Cells(X, "R"), S1.Range("G:G"))
            S2.Cells(Satır, 8) = WF.SumIf(S1.Range("R:R"), S1.Cells(X, "R"), S1.Range("H:H"))
            S2.Cells(Satır, 9) = WF.SumIf(S1.Range("R:R"), S1.Cells(X, "R"), S1.Range("I:I"))
            S2.Cells(Satır, 10) = WF.SumIf(S1.Range("R:R"), S1.Cells(X, "R"), S1.Range("J:J"))
            S2.Cells(Satır, 11) = S1.Cells(X, 11)
            S2.Cells(Satır, 12) = S1.Cells(X, 12)
            S2.Cells(Satır, 13) = S1.Cells(X, 13)
            Satır = Satır + 1
        End If
    Next
    
    S1.Range("R:R").Clear
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Özet tablonuz oluşturulmuştur.", vbInformation
End Sub
 
Korhan bey sizede Hüseyin beyede ayrı ayrı teşekkürlerimi sunarım. Çok güzel oldu elinize sağlık.

Saygılar.
 
Cüneyt bey dosyanın son halini göndermeniz mümkün müdür? Teşekkürler...
 
iyi akşamlar bir sorum var 6000 satırdaki verilerler ilgili bir icmal hazırlıyorum. a,b,c,d,e,f,g sütunlarındaki verilerden a1 hücresindeki veri a sütununda örnek a4 hücresindede var ve bu hücrelerin karşılığında a sütununda rakamlar, g sütununda farklı isimler var istediğim formül a1 hücresini a sütununda ara varsa d sütunundaki karşılıklarını isterse 10 tane olsun topla ı sütununa yaz ve g sütunundaki karşılık gelen isimleri birleştirerek j sütununa yaz ....

a b c d e g ı j
1-203 3 adem 8 ademaslı
2-
3-
4-203 5 aslı 8 ademaslı

şeklinde olmasını istiyorum 4.satırı da sildirebiliriz ama süz yaparak benzersiz kayıtları bul şeklinde çözerim...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst