Her 33 satırda ara toplam aldırmak.

[hikmet]

Merhaba Sn.Hocalarım ve Arkadaşlarım;

Ek'teki örnek dosyada 160 satırdan fazla veri mevcut olup; bu verilerin her 33 satır sonrasına otomatik olarak satır açıp ara toplam aldırmak istiyorum. Konu hakkında bilgilerinizi paylaşırmısınız lütfen. İlginiz için şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub ARA_TOPLAM_AL()
    Dim X As Long, Satır As Long, İlk_Satır As Long
    Dim TOPLAMD As Double, TOPLAME As Double, TOPLAMG As Double
 
    Application.ScreenUpdating = False
 
    On Error Resume Next
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
 
    Satır = Range("A65536").End(3).Row
    İlk_Satır = 2
 
    If Satır > 34 Then
 
        For X = 35 To Satır Step 34
            Rows(X).Insert
            Cells(X, 4) = WorksheetFunction.Sum(Range("D" & İlk_Satır & ":D" & X - 1))
            Cells(X, 5) = WorksheetFunction.Sum(Range("E" & İlk_Satır & ":E" & X - 1))
            Cells(X, 7) = WorksheetFunction.Sum(Range("G" & İlk_Satır & ":G" & X - 1))
            Range(Cells(X, 4), Cells(X, 7)).Font.Bold = True
            Range(Cells(X, 4), Cells(X, 7)).Font.ColorIndex = 3
            TOPLAMD = TOPLAMD + Cells(X, 4)
            TOPLAME = TOPLAME + Cells(X, 5)
            TOPLAMG = TOPLAMG + Cells(X, 7)
            İlk_Satır = İlk_Satır + 34
        Next
 
        Satır = Range("A65536").End(3).Row + 1
 
        Cells(Satır, 4) = WorksheetFunction.Sum(Range("D" & İlk_Satır & ":D" & X - 1))
        Cells(Satır, 5) = WorksheetFunction.Sum(Range("E" & İlk_Satır & ":E" & X - 1))
        Cells(Satır, 7) = WorksheetFunction.Sum(Range("G" & İlk_Satır & ":G" & X - 1))
        TOPLAMD = TOPLAMD + Cells(Satır, 4)
        TOPLAME = TOPLAME + Cells(Satır, 5)
        TOPLAMG = TOPLAMG + Cells(Satır, 7)
        Cells(Satır + 1, 4) = TOPLAMD
        Cells(Satır + 1, 5) = TOPLAME
        Cells(Satır + 1, 7) = TOPLAMG
        Range(Cells(Satır, 4), Cells(Satır + 1, 7)).Font.Bold = True
        Range(Cells(Satır, 4), Cells(Satır + 1, 7)).Font.ColorIndex = 3
 
    Else
 
        Satır = Range("A65536").End(3).Row + 1
 
        Cells(Satır, 4) = WorksheetFunction.Sum(Range("D" & İlk_Satır & ":D" & Satır - 1))
        Cells(Satır, 5) = WorksheetFunction.Sum(Range("E" & İlk_Satır & ":E" & Satır - 1))
        Cells(Satır, 7) = WorksheetFunction.Sum(Range("G" & İlk_Satır & ":G" & Satır - 1))
        Range(Cells(Satır, 4), Cells(Satır, 7)).Font.Bold = True
        Range(Cells(Satır, 4), Cells(Satır, 7)).Font.ColorIndex = 3
 
    End If
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hikmet]

Korhan hocam elinize sağlık süper oldu. emeğiniz için ve ilgilenen herkese teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodda küçük değişiklik yaptım. Değişkenleri yanlış toplatmışım. Lütfen son halini kullanınız.