SUMIF yerine makro ile toplam sayfasi olusturma

[yabanci_biri]

Selamlar

Bilmiyorum baslik derdimi analatbildimi ama yapmak istedigim soyle bir sey.
Elimde haftalik degisen 15000-20000 satirli bir veri dosyasi var. B sutunundaki kisiler yeni musterilerin olusmasi sonucu surekli artmakta. Yapmak istedigim bir tus ile ayri bir sayfaya mevcut kisi listesi ve bakiyesini cikaracak bir formul.
Insallah derdimi anlatabilmisimdir.

Simdiden cok tesekkurler

 

[Levent Menteşoğlu]

Aşağıdaki kodu dosyanızda bir butona bağlayarak çalıştırın.

Sub listele()
Set s1 = Sheets("sheet1")
Set s2 = Sheets("toplama")
s2.[b2:c65536].ClearContents
For a = 2 To s1.[b65536].End(3).Row
If WorksheetFunction.CountIf(s1.Range("b2:b" & a), s1.Cells(a, "b")) = 1 Then
c = c + 1
s2.Cells(c + 1, "b") = s1.Cells(a, "b")
s2.Cells(c + 1, "c") = WorksheetFunction.SumIf(s1.[b:b], s1.Cells(a, "b"), s1.[d:d])
End If
Next
s2.[b2:c65536].Sort key1:=s2.[b2]
End Sub

 

[hamitcan]

Aşağıdaki kodu dener misiniz?

Sub MUK()
k = 1
Sheets(2).[b2:b65536].ClearContents
son = [b65536].End(3).Row
For t = 2 To son
    say = WorksheetFunction.CountIf(Columns(2), Cells(t, 2))
    say2 = WorksheetFunction.CountIf(Sheets(2).Columns(2), Cells(t, 2))
    
If say >= 1 And say2 = 0 Then
    k = k + 1
    Sheets(2).Cells(k, 2) = Cells(t, 2)
    Sheets(2).Cells(k, 3) = WorksheetFunction.SumIf(Columns(2), Sheets(2).Cells(k, 2), Columns(4))
End If
Next
End Sub

 

[yabanci_biri]

Ustam cok tesekkurler
Kodlar calisti ve sorumun cevabini aldim
Aslinda islem yapmak istedigim dosya cok buyuk ve cok kapsamli ben cok kisa sordum verdiginiz kodlari anlayip uzerinde kafa yorarak insallah asil istedigimi elde edicem.
Eger altindan kalkamazsam tabiki yine sizi muraacat edicez

 

[yabanci_biri]

Aşağıdaki kodu dosyanızda bir butona bağlayarak çalıştırın.

Sub listele()
Set s1 = Sheets("sheet1")
Set s2 = Sheets("toplama")
s2.[b2:c65536].ClearContents
For a = 2 To s1.[b65536].End(3).Row
If WorksheetFunction.CountIf(s1.Range("b2:b" & a), s1.Cells(a, "b")) = 1 Then
c = c + 1
s2.Cells(c + 1, "b") = s1.Cells(a, "b")
s2.Cells(c + 1, "c") = WorksheetFunction.SumIf(s1.[b:b], s1.Cells(a, "b"), s1.[d:d])
End If
Next
s2.[b2:c65536].Sort key1:=s2.[b2]
End Sub

Ustam bu fonksiyona ek olarak odemesi yapilmamis fatursa sayisini nasil yapmam lazim.
Ekteki dosyada sorumun ornegi var

 

[İdris SERDAR]

Ustam bu fonksiyona ek olarak odemesi yapilmamis fatursa sayisini nasil yapmam lazim.
Ekteki dosyada sorumun ornegi var

Dosyanız ekte. (Makrosuz)

1. Verilerinizin olduğu sayfada Data/List uygulaması yapılmış ve bir sütun eklenmiştir.

2. Özet sayfası Pivot Table - Özet Tablo ile yapılmıştır.


Sözü geçen konular hakkında bilgi için Excel Dersanesi'ne bakın.

.

 

[yabanci_biri]

Dosyanız ekte. (Makrosuz)

1. Verilerinizin olduğu sayfada Data/List uygulaması yapılmış ve bir sütun eklenmiştir.

2. Özet sayfası Pivot Table - Özet Tablo ile yapılmıştır.


Sözü geçen konular hakkında bilgi için Excel Dersanesi'ne bakın.

.

Ustam cok tesekkur ederim yardimin icin ancak benim ornek olarak verdigim dosya daha buyuk ve daha kapsamli. Bsak abir program otomatik olusturuyor. Ve bu dosya her gun degisiyor. Ben bu yuzden makro olsun istedim.
Birde makrolu haliyle su anda kullaniyorum bu makroya ek yaparak odenmemis fatura sayisini bulmak istedim

 

[Recep İpek]

Aşağıdaki kodları kullanabilirsiniz.

Sub AktarTopla()
Dim a, i, n, k, b()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Toplama")
'*******************************************
a = s1.Range("b2:f" & s1.[b65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 6)
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, 3)
                    b(.Item(a(i, 1)), 4) = b(.Item(a(i, 1)), 4) + a(i, 4)
                    b(.Item(a(i, 1)), 5) = b(.Item(a(i, 1)), 5) + a(i, 5)
                    If a(i, 5) <> 0 And a(i, 1) <> "Genel Toplam" Then
                        b(.Item(a(i, 1)), 6) = b(.Item(a(i, 1)), 6) + 1
                    End If
          End If
    Next
End With
s2.Range("a2:f50000").ClearContents
s2.[a2].Resize(n, 6).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Recep İpek]

Eğer ödenmemiş faturaların tarihlerinide görmek isterseniz aşağıdaki kodları kullanabilirsiniz.

Sub AktarTopla()
Dim a, i, n, k, b()
Set s1 = Sheets("VERİ")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("b2:f" & s1.[b65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 7)
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, 3)
                    b(.Item(a(i, 1)), 4) = b(.Item(a(i, 1)), 4) + a(i, 4)
                    b(.Item(a(i, 1)), 5) = b(.Item(a(i, 1)), 5) + a(i, 5)
                    If a(i, 5) <> 0 And a(i, 1) <> "Genel Toplam" Then
                        b(.Item(a(i, 1)), 6) = b(.Item(a(i, 1)), 6) + 1
                        b(.Item(a(i, 1)), 7) = b(.Item(a(i, 1)), 7) & a(i, 2) & " : "
                    End If
                End If
    Next
End With
s2.Range("a3:g50000").ClearContents
s2.[a3].Resize(n, 7).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[yabanci_biri]

Ustam cok tesekkurler

Hem isimi gordum hemde azda olsa bir seyler ogrendim
Supersiniz