I have to run this code on a sheet of about 5000 rows. At this point I could do it faster manually. I need to add a new row, carry a few values down from the previous row, create subtotals, and reshade wherever there is a change in column 'G'. This code will start in row 8 and only needs to be applied to cells E:X. Is there a better way to do this?

On further testing it seems the issue is that I'm having to add hundreds of rows individually. Is there a way to find all the rows where the value is not equal to the one above and add all rows en masse?

Sub subtotals()

'counter variables
cs = 8
c = 8


Do Until Range("E" & r) = ""


c = r
cs = r

'Do until Material Column does not equal material above
Do Until Range("g" & r) <> Range("g" & r   1)
c = c   1
r = r   1
Loop

r = r   1

Rows(r).Insert

'total label in SECTION
x = "e"
Range(x & r) = "Total"

x = "q"
Range(x & r).Formula = "=sum(" & x & cs & ":" & x & c & ")"

'rows to shade
Range("E" & r, "x" & r).Locked = True
Range("E" & r, "x" & r).Select

'shading
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.499984740745262
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.Bold = True
End With
Selection.HorizontalAlignment = xlCenter

r = r   1

Loop
End Sub

CodePudding user response：

Insert Subtotals

• Up to a thousand inserted rows this will behave i.e. it'll take a few seconds. After that, it might take forever.
• Try implementing Application.Calculation and Application.ScreenUpdating into your code. Its usage is pretty straightforward. It will speed up your code.

Option Explicit

Sub InsertSubtotals()
    
    Const wsName As String = "Sheet1" ' adjust
    Const fRow As Long = 8 ' First Row
    Const tCol As String = "E" ' Total Column
    Const cCol As String = "G" ' Criteria (Search) Column
    Const fCol As String = "Q" ' Formula Column
    Const fCols As String = "E:X" ' Format Columns
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code

    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, tCol).End(xlUp).Row
    If lRow < fRow Then Exit Sub ' no data

    Dim pRow As Long: pRow = lRow   1

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim trg As Range ' Total Range
    Dim OldValue As Variant
    Dim NewValue As Variant
    Dim r As Long
    Dim pFormula As String
    
    For r = pRow To fRow   1 Step -1
        NewValue = ws.Cells(r - 1, cCol).Value
        If StrComp(CStr(NewValue), CStr(OldValue), vbTextCompare) <> 0 Then
            If pRow > r Then
                WriteFormula ws, r, pRow, fCol
                pRow = r
            End If
            ws.Rows(r).Insert
            If Not trg Is Nothing Then
                Set trg = Union(trg, ws.Cells(r, tCol))
            Else
                Set trg = ws.Cells(r, tCol)
            End If
            OldValue = NewValue
        End If
    Next r
    WriteFormula ws, fRow, pRow, fCol
     
    ' Write 'Total' in one go.
    trg.Value = "Total"
    
    ' Apply formatting in one go.
    With Intersect(trg.EntireRow, ws.Columns(fCols))
        .Locked = True
        With .Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark2
            .TintAndShade = -0.499984740745262
            .PatternTintAndShade = 0
        End With
        With .Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .Bold = True
        End With
        .HorizontalAlignment = xlCenter
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Sub WriteFormula( _
        ByVal ws As Worksheet, _
        ByVal r As Long, _
        ByVal pRow As Long, _
        ByVal ColumnString As String)
    Dim pFormula As String
    pFormula = "=SUM(" & ColumnString & r & ":" & ColumnString & pRow - 1 & ")"
    ws.Cells(pRow, ColumnString).Formula = pFormula
End Sub