Topla.çarpım yerine vba kod ihtiyacı

[muslant]

Arkadaşlar örnek dosyamda topla.çarpım formülü ile aldığım raporu vba kod ile almak istiyorum ama kod yazmada çok iyi değilim.
yardımlarını bekliyorum.. detaylı açıklama dosyadadır.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Sub RAPORLA()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim X As Long, Y As Long, Tarih1 As Date, Tarih2 As Date
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    
    For X = 1 To S3.Cells(Rows.Count, 2).End(3).Row Step 22
        Tarih1 = S3.Cells(X, 1)
        Tarih2 = S3.Cells(X, 1) + 1
        
        For Y = X + 1 To X + 20
            If S3.Cells(Y, 2) <> "" Then
                For Z = 4 To 7
                    If Not S1.AutoFilterMode Then S1.Range("2:2").AutoFilter
                    With S1
                        .Range("A2").AutoFilter Field:=1, Criteria1:=S3.Cells(Y, 2)
                        .Range("A2").AutoFilter Field:=2, Criteria1:=">=" & CDate(CLng(Tarih1)), Operator:=xlAnd, Criteria2:="<" & CDate(CLng(Tarih2))
                        .Range("A2").AutoFilter Field:=3, Criteria1:=S3.Cells(1, Z)
                         S3.Cells(Y, Z) = WorksheetFunction.Subtotal(3, .Range("C3:C65536"))
                         S3.Cells(Y, 3) = WorksheetFunction.Sum(S3.Range("D" & Y & ":G" & Y))
                    End With
                    
                    If Not S2.AutoFilterMode Then S2.Range("2:2").AutoFilter
                    With S2
                        .Range("A2").AutoFilter Field:=2, Criteria1:=S3.Cells(Y, 2)
                        .Range("A2").AutoFilter Field:=3, Criteria1:=">=" & CDate(CLng(Tarih1)), Operator:=xlAnd, Criteria2:="<" & CDate(CLng(Tarih2))
                         S3.Cells(Y, 8) = WorksheetFunction.Subtotal(3, .Range("C3:C65536"))
                    End With
                Next
            Else
                GoTo 10
            End If
        Next
10  Next
    
    S1.Range("A2:D2").AutoFilter
    S2.Range("A2:D2").AutoFilter
 
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[muslant]

teşekkür ederim işimi görecektir..