Özet Tabloyu iki farklı kıstasa göre alma

[Eneserhat]

merhaba,

bir özet tablo alıyorum. Aldığım özet tablo için iki farklı kıstasa göre farklı bir özet tablo alıyorum. Örneğin listede A sütunundaki her isim için 1. kıstası listede kontrol ediyorum, bunu sağlarsa özet tabloda boyuyorum. 1. kıstası sağlamazsa 2. kıstası kontrol ediyorum, sağlarsa özet tabloda boyuyorum. Her iki kıstas için tek bir renk kullanıyorum.
Kıstasları sağlamayan isimleri tabloda ayrı bir yere veya boyalıların altında sıralıyorum.
Bu şekilde bir özet tabloyu formül veya kod ile yapabilir miyim? Çünkü listemde 30-32 bin civarı isim satır var. Yardımlarınız için şimdiden teşekkürler.
Ekteki dosyada anlatmaya çalıştım.

 

[BedirHan_]

Dosya Ektedir. ( Boyama kıstaslarını koşullu biçimlendirme ile yapabilirsin- boyama kıstasını tam anlamadım)

 

[Eneserhat]

Etopla formülü aldığınız tabloyu kıstaslara göre nasıl sıraladığınızı öğrenebilir miyim? Çünkü benim listemde en az 30 bin satır var.
Teşekkürler

 

[Vedat Özer]

Merhabalar,

Alternatif olarak

Aşagıdaki kodu boş bir modül oluşturup deneyiniz.

Sub AktarTopla()
Dim a, i, n, sat, veri(), Zaman As Double

Zaman = Timer
    
With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

Set s1 = Sheets("kıstasa göre özet tablo ekleme")
a = s1.Range("a2:c" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 3)

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
                    veri(n, 1) = a(i, 1)
                   .Add a(i, 1), n
                  End If
                    veri(.Item(a(i, 1)), 2) = veri(.Item(a(i, 1)), 2) + a(i, 2)
                    veri(.Item(a(i, 1)), 3) = veri(.Item(a(i, 1)), 3) + a(i, 3)
            End If
    Next i
End With
sat = s1.[j65536].End(3).Row + 1
s1.Range("I2:K65536").ClearContents
s1.[ı2].Resize(n, 3).Value = veri
With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
 MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
Set s1 = Nothing
End Sub

 

[Eneserhat]

Merhabalar,

Alternatif olarak

Aşagıdaki kodu boş bir modül oluşturup deneyiniz.

Sub AktarTopla()
Dim a, i, n, sat, veri(), Zaman As Double

Zaman = Timer
    
With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

Set s1 = Sheets("kıstasa göre özet tablo ekleme")
a = s1.Range("a2:c" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 3)

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
                    veri(n, 1) = a(i, 1)
                   .Add a(i, 1), n
                  End If
                    veri(.Item(a(i, 1)), 2) = veri(.Item(a(i, 1)), 2) + a(i, 2)
                    veri(.Item(a(i, 1)), 3) = veri(.Item(a(i, 1)), 3) + a(i, 3)
            End If
    Next i
End With
sat = s1.[j65536].End(3).Row + 1
s1.Range("I2:K65536").ClearContents
s1.[ı2].Resize(n, 3).Value = veri
With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
 MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
Set s1 = Nothing
End Sub

Vedat Bey teşekkürler,
Özet tablo çıkartıyor ama belirttiğim( tek satırda 24.000 üstünü al, eğer altındaysa toplamı 75.000 üstünü al) koşullarını sağlayanlar belli (renk veya tablonun en üstünde) olmuyor.:frown: