Macro to Split Rows and Generate Totals

[JimmyC]

I have modified the code below that was originally provided by Rudi for another project. Rudi's original code worked perfectly.

My need now is similar, so I thought that I would try modify Rudi's original code and learn along the way. What I need is to examine Column B and when there is a change, insert two blank rows. In the first of the two newly inserted rows, I need a total in BOLD font in Columns K, Q and R. When I try to compile the code below, I receive a Compile Error Dialog that states "End if without Block If". The "End if" statement is then highlight. As stated previously, the original code from Rudi ran perfect--so I must have messed something up in the revision---

Code: Select all

Sub CreateTotals()
Dim lRow As Long
Dim Rng As Range
Dim i As Integer

    Application.ScreenUpdating = False
    For lRow = Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
        If Cells(lRow, "B") <> Cells(lRow - 1, "B") Then Rows(lRow).Resize(2).EntireRow.Insert
    Next lRow
    For Each Rng In Columns("B").SpecialCells(xlCellTypeConstants).Areas
        i = i + 1
        If i = 1 Then
            Rng.Offset(1).Resize(2).EntireRow.Delete
        Else
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 9)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 16)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 17)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
           End With
        End If
    Next Rng
    Application.ScreenUpdating = True
    
End Sub

[Rudi]

I have not checked the code, but I can immediately see that you are missing End With statements..

Edit the macro with these:

Code: Select all

            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 9)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            End With
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 16)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            End With
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 17)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            End With

[JimmyC]

Rudi---THANK YOU!!! I didn't realize that each "With"...needed an "End With". Your original code had only one With/end with section---so I assumed that I could insert two more without the "end with". I am getting dangerous with this VBA stuff. Again, thank you. Jim

[Rudi]

I'm impressed that you used the Areas property
This is not a novice option (at least IMHO).

[JimmyC]

I am successfully using the code below originally provided by Rudi and modified per Rudi's advice earlier in this thread.

Code: Select all

Sub CreateTotals()
Dim lRow As Long
Dim Rng As Range
Dim i As Integer

    Application.ScreenUpdating = False
    For lRow = Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
        If Cells(lRow, "B") <> Cells(lRow - 1, "B") Then Rows(lRow).Resize(2).EntireRow.Insert
    Next lRow
    For Each Rng In Columns("B").SpecialCells(xlCellTypeConstants).Areas
        i = i + 1
        If i = 1 Then
            Rng.Offset(1).Resize(2).EntireRow.Delete
        Else
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 9)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            End With
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 15)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            End With
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 16)
                .FormulaR1C1 = "=SUM(R[-1]C:R[-" & Rng.Rows.Count & "]C)"
                .Font.Bold = True
            End With
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, -1)
                .FormulaR1C1 = "=(R[-1]C)"
                .Font.Bold = True
            End With
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 0)
                .FormulaR1C1 = "=(R[-1]C)"
                .Font.Bold = True
            End With
            With Rng.Offset(Rng.Rows.Count).Cells(1).Offset(0, 6)
                .FormulaR1C1 = "=(R[-1]C)"
                .Font.Bold = True
            End With
        End If
    Next Rng
    Application.ScreenUpdating = True
    
End Sub

What I have been asked to do now, and forgive me if I should have started a new thread, is copy the data generated by the "with" statements in Columns A,B,H,K,Q and R to a new sheet. The individual wants a sheet that only captures the total line created by the "with" statements in the code above. I have no clue how to do this or whether it should be done in the code above or should be done with separate code after the code above executes. I have been googling but just can't seem to find any suggestions to help me get started or even muddle through without seeking help. Thanks. JimC

[Rudi]

Although it can be merged into the above macro, it might be better to have it as a separate one so you can choose to run it and create the summary, or not.

Here is some code to compile the summary on a new sheet.

Code: Select all

Sub GetTotals()
Dim shS As Worksheet
Dim shD As Worksheet
Dim rgS As Range
    Application.ScreenUpdating = False
    Set shS = ActiveSheet
    On Error Resume Next
    Set rgS = shS.Columns("A").SpecialCells(xlCellTypeFormulas, 23)
    If rgS Is Nothing Then Exit Sub
    Set shD = Sheets.Add(After:=shS)
    shS.Columns("A").SpecialCells(xlCellTypeFormulas, 23).EntireRow.Copy
    shD.Range("A1").PasteSpecial Paste:=xlPasteValues
    shS.Rows(1).Copy
    shD.Rows(1).Insert Shift:=xlDown
    Application.CutCopyMode = False
    shD.Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
    shD.Columns.AutoFit
    shD.Cells(1).Select
    Application.ScreenUpdating = True
End Sub

[JimmyC]

Rudi---thank you. Wow, your skills are awesome. Again, thank you. Jim