Aylık okuma rapor

[Hakan ERDOST]

Sınıf kitaplık uygulaması yapmaya çalışıyorum. Soruna ilişkin açıklama ekli çalışma kitabının OKUMA adlı sayfasında mevcut. İlgileneceklere şimdiden teşekkürler.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Kendinize uyarlarsınız.

Sub RAPOR()
    Dim S1 As Worksheet, S2 As Worksheet, WF As WorksheetFunction
    Dim Son As Long, Satir As Long, X As Long, Bul As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("OKUMA")
    Set S2 = Sheets("AY_RAPOR")
    Set WF = WorksheetFunction
    
    S2.Range("A4:P" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Satir = 4
    
    For X = 2 To Son
        If S1.Cells(X, 2) <> "" Then
            If WF.CountIf(S2.Range("C:C"), S1.Cells(X, 2)) = 0 Then
                S2.Cells(Satir, 1) = Satir - 3
                S2.Cells(Satir, 3) = S1.Cells(X, 2)
                For Y = 4 To 15
                    If Month(S1.Cells(X, 7)) = Y - 3 Then
                        S2.Cells(Satir, Y) = S2.Cells(Satir, Y) + S1.Cells(X, 4)
                    End If
                Next
                S2.Cells(Satir, 16) = WF.Sum(S2.Range("D" & Satir & ":O" & Satir))
                Satir = Satir + 1
            Else
                Set Bul = S2.Range("C:C").Find(S1.Cells(X, 2), , , xlWhole)
                If Not Bul Is Nothing Then
                    For Y = 4 To 15
                        If Month(S1.Cells(X, 7)) = Y - 3 Then
                            S2.Cells(Bul.Row, Y) = S2.Cells(Bul.Row, Y) + S1.Cells(X, 4)
                        End If
                    Next
                    S2.Cells(Bul.Row, 16) = WF.Sum(S2.Range("D" & Bul.Row & ":O" & Bul.Row))
                End If
            End If
        End If
    Next

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ziynettin]

Bende yazmıştım alternatif olsun

Sub tablo()
Set s1 = Sheets("OKUMA")
Set s2 = Sheets("AY_RAPOR")
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
a = s1.Range("B2:G" & s1.Range("A" & Rows.Count).End(3).Row)
    For i = 1 To UBound(a)
        ad = UCase(Replace(Replace(a(i, 1), "i", "İ"), "ı", "I"))
        ay = UCase(Replace(Replace(Format(a(i, 6), "mmmm"), "i", "İ"), "ı", "I"))
        krt = ad & "|" & ay
        If Not IsEmpty(a(i, 1)) Then
            d1(ad) = ""
            d(krt) = d(krt) + a(i, 3) * 1
        End If
    Next i
s2.Range("C4:P" & Rows.Count).ClearContents
s2.[C4].Resize(d1.Count) = Application.Transpose(d1.keys)
c = s2.[C4].Resize(d1.Count).Value
e = s2.[D3:O3]
ReDim v(1 To UBound(c), 1 To UBound(e, 2))
    For i = 1 To UBound(c)
        For X = 1 To UBound(e, 2)
            v(i, X) = (d(c(i, 1) & "|" & e(1, X)))
        Next X
    Next i
s2.[D4].Resize(d1.Count, UBound(e, 2)) = v
ReDim t(1 To d1.Count, 1 To 1)
    For i = 1 To d.Count
        t(i, 1) = Application.Sum(Application.Index(v, i))
    Next i
s2.[P4].Resize(d1.Count) = t
MsgBox "İşleminiz tamamlandı.....", vbInformation
End Sub

 

[Hakan ERDOST]

Sayın Korhan AYHAN ve Ziynettin teşekkürler.