Excel VBA Macro to Auto Insert row and insert Total and sum

Jyotirmaya · Sunday at 4:38 AM

I am using the below code to insert total in the rows based on the Serial Number in Row A starting from Row 6, there are more than 5000 rows in a sheet.
But when there are two serial numbers like in this example A15 and A16, the below code doesn't add a new row Total below the A15. it inserted the total in A17 and inserted a blank row in A14. instead of inserting total in A16 and the last total in A17.

VBA Code:

Sub InsertTotals()

   Dim Rng As Range
   
   With Range("A7:A" & Range("G" & Rows.Count).End(xlUp).Row)
      .SpecialCells(xlConstants).EntireRow.Insert
   End With
   
   With Range("G6", Range("G" & Rows.Count).End(xlUp))
      For Each Rng In .SpecialCells(xlConstants).Areas
         If Rng.Offset(Rng.Count - 1).Resize(1).Value = "Total" Then Rng.Offset(Rng.Count - 1).Resize(1).EntireRow.Delete
         Rng.Offset(Rng.Count).Resize(1).Value = "Total"
         With Rng.Offset(Rng.Count, 1).Resize(1, 2)
            .Formula = "=sum(" & Rng.Offset(, 1).Address(False, False) & ")"
         End With
      Next Rng
   End With
End Sub

Getting Result like this

I want result like this

Please help me, what to change the code ??

Logit · Sunday at 7:03 AM

Try the following edited macro :

VBA Code:

Option Explicit

Sub InsertTotalsAndRemoveBlanks()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim area As Range
    Dim totalRow As Range
    Dim rowNum As Long
    
    ' Set the worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' Determine the last used row in Column H
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Last Row: " & lastRow
    
    ' Insert "Total" rows with formulas for each data block in Column H
    On Error Resume Next ' Handle potential cases where no constants are found
    With ws.Range("H6:H" & lastRow)
        For Each area In .SpecialCells(xlConstants).Areas
            On Error GoTo 0
            
            ' Check if the last row of the area already contains "Total"
            Debug.Print "Area Address: " & area.Address
            If area.Cells(area.Rows.Count, 1).Value <> "Total" Then
                ' Insert "Total" row below the current area
                Set totalRow = area.Cells(area.Rows.Count, 1).Offset(1)
                totalRow.Value = "Total"
                
                ' Add formulas in adjacent columns (I and J)
                With totalRow.Offset(0, 1).Resize(1, 2)
                    .Formula = "=SUM(" & area.Offset(0, 1).Resize(area.Rows.Count, 1).Address(False, False) & ")"
                End With
                Debug.Print "Inserted Total at: " & totalRow.Address
            End If
        Next area
    End With
    
    On Error GoTo 0 ' Disable error handling after inserting totals
    
    ' Update lastRow after all "Total" rows are added
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Updated Last Row: " & lastRow
    
    ' Remove any blank rows above the last "Total" row, starting from row 3
    For rowNum = lastRow - 1 To 3 Step -1
        If ws.Cells(rowNum, 8).Value = "" Then ' Check if Column H is empty
            ws.Rows(rowNum).Delete
            Debug.Print "Deleted Row: " & rowNum
        End If
    Next rowNum
End Sub

Jyotirmaya · Sunday at 9:04 AM

Logit said:

Try the following edited macro :

VBA Code:

Option Explicit

Sub InsertTotalsAndRemoveBlanks()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim area As Range
    Dim totalRow As Range
    Dim rowNum As Long
  
    ' Set the worksheet
    Set ws = ThisWorkbook.ActiveSheet
  
    ' Determine the last used row in Column H
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Last Row: " & lastRow
  
    ' Insert "Total" rows with formulas for each data block in Column H
    On Error Resume Next ' Handle potential cases where no constants are found
    With ws.Range("H6:H" & lastRow)
        For Each area In .SpecialCells(xlConstants).Areas
            On Error GoTo 0
          
            ' Check if the last row of the area already contains "Total"
            Debug.Print "Area Address: " & area.Address
            If area.Cells(area.Rows.Count, 1).Value <> "Total" Then
                ' Insert "Total" row below the current area
                Set totalRow = area.Cells(area.Rows.Count, 1).Offset(1)
                totalRow.Value = "Total"
              
                ' Add formulas in adjacent columns (I and J)
                With totalRow.Offset(0, 1).Resize(1, 2)
                    .Formula = "=SUM(" & area.Offset(0, 1).Resize(area.Rows.Count, 1).Address(False, False) & ")"
                End With
                Debug.Print "Inserted Total at: " & totalRow.Address
            End If
        Next area
    End With
  
    On Error GoTo 0 ' Disable error handling after inserting totals
  
    ' Update lastRow after all "Total" rows are added
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Updated Last Row: " & lastRow
  
    ' Remove any blank rows above the last "Total" row, starting from row 3
    For rowNum = lastRow - 1 To 3 Step -1
        If ws.Cells(rowNum, 8).Value = "" Then ' Check if Column H is empty
            ws.Rows(rowNum).Delete
            Debug.Print "Deleted Row: " & rowNum
        End If
    Next rowNum
End Sub

Thank you for the response but its not working, the result came like this, it did not add the "Total" after end of the each serial in Column G, it only inserted the Total at the end of all values

Logit · Sunday at 10:17 AM

Ok, let's try this edited macro version :

VBA Code:

Sub InsertTotalsAndRemoveBlanks()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim area As Range
    Dim totalRow As Range
    Dim rowNum As Long
    
    ' Set the worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' Move rows 16 and 17 down one row
    ws.Rows("16:17").Insert Shift:=xlDown
    
    ' Insert "Total" in H16
    ws.Cells(16, 8).Value = "Total"
    
    ' Determine the last used row in Column H
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Last Row: " & lastRow
    
    ' Insert "Total" rows with formulas for each data block in Column H
    On Error Resume Next ' Handle potential cases where no constants are found
    With ws.Range("H6:H" & lastRow)
        For Each area In .SpecialCells(xlConstants).Areas
            On Error GoTo 0
            
            ' Check if the last row of the area already contains "Total"
            Debug.Print "Area Address: " & area.Address
            If area.Cells(area.Rows.Count, 1).Value <> "Total" Then
                ' Insert "Total" row below the current area
                Set totalRow = area.Cells(area.Rows.Count, 1).Offset(1)
                totalRow.Value = "Total"
                
                ' Add formulas in adjacent columns (I and J)
                With totalRow.Offset(0, 1).Resize(1, 2)
                    .Formula = "=SUM(" & area.Offset(0, 1).Resize(area.Rows.Count, 1).Address(False, False) & ")"
                End With
                Debug.Print "Inserted Total at: " & totalRow.Address
            End If
        Next area
    End With
    
    On Error GoTo 0 ' Disable error handling after inserting totals
    
    ' Update lastRow after all "Total" rows are added
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Updated Last Row: " & lastRow
    
    ' Remove any blank rows above the last "Total" row, starting from row 3
    For rowNum = lastRow - 1 To 3 Step -1
        If ws.Cells(rowNum, 8).Value = "" Then ' Check if Column H is empty
            ws.Rows(rowNum).Delete
            Debug.Print "Deleted Row: " & rowNum
        End If
    Next rowNum
End Sub

Jyotirmaya · Sunday at 10:35 AM

Logit said:

Ok, let's try this edited macro version :

VBA Code:

Sub InsertTotalsAndRemoveBlanks()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim area As Range
    Dim totalRow As Range
    Dim rowNum As Long
  
    ' Set the worksheet
    Set ws = ThisWorkbook.ActiveSheet
  
    ' Move rows 16 and 17 down one row
    ws.Rows("16:17").Insert Shift:=xlDown
  
    ' Insert "Total" in H16
    ws.Cells(16, 8).Value = "Total"
  
    ' Determine the last used row in Column H
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Last Row: " & lastRow
  
    ' Insert "Total" rows with formulas for each data block in Column H
    On Error Resume Next ' Handle potential cases where no constants are found
    With ws.Range("H6:H" & lastRow)
        For Each area In .SpecialCells(xlConstants).Areas
            On Error GoTo 0
          
            ' Check if the last row of the area already contains "Total"
            Debug.Print "Area Address: " & area.Address
            If area.Cells(area.Rows.Count, 1).Value <> "Total" Then
                ' Insert "Total" row below the current area
                Set totalRow = area.Cells(area.Rows.Count, 1).Offset(1)
                totalRow.Value = "Total"
              
                ' Add formulas in adjacent columns (I and J)
                With totalRow.Offset(0, 1).Resize(1, 2)
                    .Formula = "=SUM(" & area.Offset(0, 1).Resize(area.Rows.Count, 1).Address(False, False) & ")"
                End With
                Debug.Print "Inserted Total at: " & totalRow.Address
            End If
        Next area
    End With
  
    On Error GoTo 0 ' Disable error handling after inserting totals
  
    ' Update lastRow after all "Total" rows are added
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    Debug.Print "Updated Last Row: " & lastRow
  
    ' Remove any blank rows above the last "Total" row, starting from row 3
    For rowNum = lastRow - 1 To 3 Step -1
        If ws.Cells(rowNum, 8).Value = "" Then ' Check if Column H is empty
            ws.Rows(rowNum).Delete
            Debug.Print "Deleted Row: " & rowNum
        End If
    Next rowNum
End Sub

This one looks like this and I want the TOTAL text in G Column, its coming in H and coming at the end only. Please check to help me

Logit · Sunday at 2:45 PM

Hopefully this version will produce the results you are seeking :

VBA Code:

Option Explicit

Sub InsertTotalsAndRemoveBlanks()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim area As Range
    Dim totalRow As Range
    Dim rowNum As Long
    
    ' Set the worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' Determine the last used row in Column G
    lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    Debug.Print "Last Row: " & lastRow
    
    ' Insert "Total" rows with formulas for each data block in Column G
    On Error Resume Next ' Handle potential cases where no constants are found
    With ws.Range("G6:G" & lastRow)
        For Each area In .SpecialCells(xlConstants).Areas
            On Error GoTo 0
            
            ' Check if the last row of the area already contains "Total"
            Debug.Print "Area Address: " & area.Address
            If area.Cells(area.Rows.Count, 1).Value <> "Total" Then
                ' Insert "Total" row below the current area
                Set totalRow = area.Cells(area.Rows.Count, 1).Offset(1)
                totalRow.Value = "Total"
                
                ' Add formulas in adjacent columns (H and I)
                With totalRow.Offset(0, 1).Resize(1, 2)
                    .Formula = "=SUM(" & area.Offset(0, 1).Resize(area.Rows.Count, 1).Address(False, False) & ")"
                End With
                Debug.Print "Inserted Total at: " & totalRow.Address

                ' Center align the "Total" cell
                totalRow.HorizontalAlignment = xlCenter
            End If
        Next area
    End With
    
    On Error GoTo 0 ' Disable error handling after inserting totals
    
    ' Update lastRow after all "Total" rows are added
    lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    Debug.Print "Updated Last Row: " & lastRow
    
    ' Remove any blank rows above the last "Total" row, starting from row 3
    For rowNum = lastRow - 1 To 3 Step -1
        If ws.Cells(rowNum, 7).Value = "" Then ' Check if Column G is empty
            ws.Rows(rowNum).Delete
            Debug.Print "Deleted Row: " & rowNum
        End If
    Next rowNum
    
    ' Center align specific cells
    ws.Range("G3:I3").HorizontalAlignment = xlCenter
    
    ' Center align all cells containing the term "Total"
    For rowNum = 6 To lastRow
        If ws.Cells(rowNum, 7).Value = "Total" Then
            ws.Cells(rowNum, 7).HorizontalAlignment = xlCenter
        End If
    Next rowNum
    
    Worksheets("Sheet1").Columns("A:K").AutoFit

    
End Sub

Macropod · Sunday at 7:17 PM

Cross-posted - and marked as answered - at: Excel VBA Macro to Auto Insert row and insert Total and sum
Please read Mr Excel's policy on Cross-Posting in rule 13: http://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html

Logit · Sunday at 9:46 PM

Interesting. The result on stackoverflow.com doesn't match the image he posted above. ???

maxpit · Monday at 7:12 AM

Hi all,

@Logit the answer on stackoverflow.com is correct and working, but was not understood by the person who opened the post.

See you soon.

Logit · Monday at 10:40 AM

I'm still confused but it really doesn't matter I guess. It's all in what the OP is acceptable to.

My Macro Results Which He Accepted
Serial	Number	Quantity A	Quantity B
1	17	0.5	0.4
18	0.4	0.4
Total	0.9	0.8
2	32	0.5	0.4
27	0.4	0.4
45	0.5	0.4
77	0.4	0.4
Total	1.8	1.6
3	444	0.66	0.75
4	789	0.478	0.489
Total	1.138	1.239

Stackoverflow Answer
Serial	Number	Quantity A	Quantity B
1	17	0.5	0.4
18	0.4	0.4
Total	0.9	0.8
Total	1.3	1.2
2	32	0.5	0.4
27	0.4	0.4
45	0.5	0.4
77	0.4	0.4
Total	1.8	1.6
Total	3.6	3.2
3	444	0.66	0.75
Total	0.66	0.75
4	789	0.478	0.489
Total	1.138	1.239
Total	1.616	1.728

The don't match.

Life goes on......

Excel VBA Macro to Auto Insert row and insert Total and sum

Jyotirmaya

Board Regular

Excel Facts

Logit

Well-known Member

Jyotirmaya

Board Regular

Logit

Well-known Member

Jyotirmaya

Board Regular

Logit

Well-known Member

Macropod

Retired Moderator

Logit

Well-known Member

maxpit

New Member

Logit

Well-known Member

Similar threads

Forum statistics

Share this page

Excel VBA Macro to Auto Insert row and insert Total and sum

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Retired Moderator

Well-known Member

New Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock