Şarta bağlı dolu hücre sayma...

[karakayalı]

Dosya Ektedir...Yardımlarınız içn şimdiden teşekkürler

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.
Referanslardan Microsoft Scripting Runtime seçili olmalıdır.

Sub OzetTabloHazirla()

'Microsoft Scripting Runtime Modülü Yüklenmeli (Ben bu yolu tercih ediyom)

Dim dic As New Dictionary
Dim ar1 As Variant
Dim ar2 As Variant
Dim arr As Variant
Dim k   As Variant
Dim i   As Long
Dim j   As Long
Dim kol As Integer


ar1 = Sayfa1.UsedRange.Value
ar2 = Sayfa2.UsedRange.Value

i = UBound(ar1, 1) + UBound(ar2, 1)
If UBound(ar1, 2) > UBound(ar2, 2) Then
    kol = UBound(ar1, 2)
Else
    kol = UBound(ar2, 2)
End If

ReDim arr(1 To i, 1 To kol)

j = 0

For i = LBound(ar1, 1) To UBound(ar1, 1)
    If Not ar1(i, 1) = "" Then
        j = j + 1
        For kol = LBound(ar1, 2) To UBound(ar1, 2)
            arr(j, kol) = ar1(i, kol)
        Next kol
    End If
Next i

For i = LBound(ar2, 1) To UBound(ar2, 1)
    If Not ar1(i, 1) = "" Then
        j = j + 1
        For kol = LBound(ar2, 2) To UBound(ar2, 2)
            arr(j, kol) = ar2(i, kol)
        Next kol
    End If
Next i

arrList arr

'j = 0
'For i = LBound(arr, 1) To UBound(arr)
'    k = arr(i, 1)
'    If Not dic.Exists(k) Then
'        j = j + 1
'        dic.Add k, j
'        arr(j, 2) = arr(i, 3)
'    Else
'        arr(dic.Item(k), 2) = arr(dic.Item(k), 2) + arr(i, 3)
'    End If
'Next i





End Sub

Sub arrList(arr As Variant)

Dim i   As Long, _
    deg As Variant, _
    jkey As Long, _
    jitm As Long, _
    k   As Integer, _
    dic As New Dictionary, _
    ayad  As Variant, _
    yil As Integer, _
    ay  As Integer


jkey = 0

For i = LBound(arr, 1) To UBound(arr, 1)
    If Not arr(i, 1) = "" Then
        deg = arr(i, 1)
        If Not dic.Exists(deg) Then
            jkey = jkey + 1
            dic.Add deg, jkey
            arr(jkey, 1) = deg
            For k = 2 To UBound(arr, 2)
                arr(dic.Item(deg), k) = arr(i, k)
            Next k
        Else
            For k = 2 To UBound(arr, 2)
                arr(dic.Item(deg), k) = arr(dic.Item(deg), k) + arr(i, k)
            Next k
        End If
    End If
Next i

Sayfa3.Cells.Clear

Sayfa3.Range("A1") = "ÖZET TABLO"
Sayfa3.Range("A2").Resize(jkey, UBound(arr, 2)) = arr

End Sub

 

[Korhan Ayhan]

Alternatif olsun...

Option Explicit

Sub Multi_Sheets_Pivot_Table()
    Dim Sh As Worksheet, My_Data As Variant, X As Long, Y As Byte, Process_Time As Double
    
    Process_Time = Timer
    
    With VBA.CreateObject("Scripting.Dictionary")
        For Each Sh In Sheets(Array("Sayfa1", "Sayfa2"))
            My_Data = Sh.Range("A3:D" & Sh.Cells(Sh.Rows.Count, 1).End(3).Row).Value
            
            For X = LBound(My_Data, 1) To UBound(My_Data, 1)
                If My_Data(X, 1) <> "" Then
                    For Y = LBound(My_Data, 2) + 1 To UBound(My_Data, 2)
                        If My_Data(X, Y) <> "" Then .Item(My_Data(X, 1)) = .Item(My_Data(X, 1)) + 1
                    Next
                End If
            Next
        Next
        
        Sheets("Sayfa3").Range("A:B").Clear
        Sheets("Sayfa3").Range("A1") = "ÖZET TABLO"
        Sheets("Sayfa3").Range("A1").Font.Bold = True
        Sheets("Sayfa3").Range("A2").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
        Sheets("Sayfa3").Columns("A:B").AutoFit
    End With

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

 

[karakayalı]

necdet bey kod hata verdi...bu işlemi BAĞ_DEĞ_DOLU_Say yapmaktayım ancak verilerim fazla olduğu için formülde hata olabiliyor...bunu başka bir formülle yapma ihtimali olabilir mi?

 

[Necdet]

necdet bey kod hata verdi...bu işlemi BAĞ_DEĞ_DOLU_Say yapmaktayım ancak verilerim fazla olduğu için formülde hata olabiliyor...bunu başka bir formülle yapma ihtimali olabilir mi?

Referans olayını halettiniz mi?
Ayrıca gönderdiğiniz örnek dosyaya göre kodları düzenledim. Sheets("Sayfa1") .Range ..... demedim Sayfa1.Range.... dedim.
Kod sayfa adlarına dikkat ediniz.

 

[Necdet]

Tekrar merhaba,

Linkteki 4. açıklamayı inceleyiniz. Bu nedenle de kod çalışmayabilir.

 

[karakayalı]

teşekkürler Necdet bey