Sütuna göre X ve Y leri saydırma

[byfika]

Merhabalar,
Sayfa7 de bulunan veri ve başlığa göre X ve Y leri Sayfa12 ye Worksheet_Activate le saydırıp alttaki kodlarla kaydediyorum. Veri yaklaşık 200 satır, Başlıklar B1 den ZZ1 e kadar devam ediyor ( başlık 701 e kadar ).
VERİ ye göre toplamı Sayfa12 kod bölümündeki kodlarla (1. sıradaki ) saydırıp kaydetmekte problem yok.
VERİYE GÖRE TOPLAMLAR:
Sheets("Sayfa12").Cells(i, "B") = WorksheetFunction.CountIf(Sheets("Sayfa7").Range("B" & i & ":ZZ" & i), "X")
Sheets("Sayfa12").Cells(i, "C") = WorksheetFunction.CountIf(Sheets("Sayfa7").Range("B" & i & ":ZZ" & i), "Y")

Problem alttaki kodlarda . Eğer alttaki gibi yazılırsa 1402 satırlık kod gerekiyor. İlk 4 sütun için kod sayfa12 var. Bu işlemi daha basit nasıl yapabiliriz.
BAŞLIĞA GÖRE TOPLAMLAR:
Range("F2").Value = WorksheetFunction.CountIf(Sayfa7.Range("B2:B65536"), "X")
Range("G2").Value = WorksheetFunction.CountIf(Sayfa7.Range("B2:B65536"), "Y")

Bilgi için Teşekkürler...

 

[muygun]

Merhaba;
Ekteki gibi olabilir.
İnceleyin.
İyi çalışmalar.

 

[byfika]

Merhabalar Sayın Muygun,
Cevabınız için çok teşekkürler, kodlar istediğim işlemi yapmakta.
Bende ilave olarak sayfa13 açıp, sayfa7 yi buraya transpose yaptım, Sayfa12 nin B ve C sütunlarına Sayfa7 den, Sayfa12 nin F ve G sütunlarına transpose yaptığım Sayfa13 den alttaki kodlarla toplamları alacak şekilde bir düzenleme yaptım..

Sheets("Sayfa12").Cells(i, "f") = WorksheetFunction.CountIf(Sheets("Sayfa13").Range("B" & i & ":ZZ" & i), "X")
Sheets("Sayfa12").Cells(i, "g") = WorksheetFunction.CountIf(Sheets("Sayfa13").Range("B" & i & ":ZZ" & i), "Y")

Sizin yazdığınız kodlar ek sayfaya gerek olmadığından daha iyi olacağını düşünmekteyim.
Tekrar teşekkürler, saygılarımla....

 

[Korhan Ayhan]

Bu da alternatif olsun.

Hız olarak avantaj sağlayabilir.

Option Explicit

Private Sub Worksheet_Activate()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Veri As Variant, Zaman As Double
    Dim Son As Long, X As Long, Y As Integer, Say As Long, X_Say As Long, Y_Say As Long
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa7")
    Set S2 = Sheets("Sayfa12")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    S2.Range("A2:G" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    Veri = S1.Range("A1").CurrentRegion.Value
    
    ReDim Liste(1 To Son, 1 To 3)
    
    For X = 2 To UBound(Veri, 1)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 1), Say
            Liste(Say, 1) = Veri(X, 1)
            For Y = 2 To UBound(Veri, 2)
                If Veri(X, Y) = "X" Then
                    X_Say = X_Say + 1
                ElseIf Veri(X, Y) = "Y" Then
                    Y_Say = Y_Say + 1
                End If
            Next
            Liste(Say, 2) = X_Say
            Liste(Say, 3) = Y_Say
            X_Say = 0: Y_Say = 0
        End If
    Next
    
    S2.Range("A2").Resize(Say, 3) = Liste
    Dizi.RemoveAll
    Erase Liste
    Say = 0
    
    ReDim Liste(1 To UBound(Veri, 2), 1 To 3)
    
    For X = 2 To UBound(Veri, 2)
        If Not Dizi.Exists(Veri(1, X)) Then
            Say = Say + 1
            Dizi.Add Veri(1, X), Say
            Liste(Say, 1) = Veri(1, X)
            For Y = 2 To UBound(Veri, 1)
                If Veri(Y, X) = "X" Then
                    X_Say = X_Say + 1
                ElseIf Veri(Y, X) = "Y" Then
                    Y_Say = Y_Say + 1
                End If
            Next
            Liste(Say, 2) = X_Say
            Liste(Say, 3) = Y_Say
            X_Say = 0: Y_Say = 0
        End If
    Next
    
    S2.Range("E2").Resize(Say, 3) = Liste
    
    S2.Columns.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[byfika]

Merhabalar Sayın Korhan Ayhan bey,
Kodları yeni gördüm. Dosyama uyarladım. 0,01 sn. gibi bir sürede işlemi gerçekleştiriyor. Harika. Çok çok teşekkürler.
Elinize bilginize sağlık. Saygılarımla...