Is there a good way to speed up this VBA code? - excel

Question

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

Answer 1

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