If you needed the pricing columns that had zero entries removed, this should work:
Sub remEmptyCol()
Dim lr, r, c As Integer
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For c = 109 To 10 Step -1
rCnt = 0
For r = lr To 3 Step -1
If Cells(r, c).Value = "" Then
rCnt = rCnt + 1
End If
Next r
If rCnt = lr - 2 Then
Cells(r, c).EntireColumn.Delete
End If
Next c
Application.ScreenUpdating = True
End Sub
This is the latest version of the main code I'm still trying to trim down.
It takes around 60 seconds on my machine...
Sub combineAccounts_v1b()
Dim x, lr As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = Worksheets("S1-var")
With ws
lr = .Cells(Rows.Count, "A").End(xlUp).Row
For x = lr To 3 Step -1
Set pFnd = .Range("I1:DE1").Find(Left(Cells(x, "EC"), Len(Cells(x, "EC")) - 3), , Excel.xlValues)
pFnd.Offset(x - 1).Value = Cells(x, 2).Value
Next x
For r = lr To 3 Step -1
If .Cells(r, "E") = .Cells(r - 1, "E") Then
For c = 10 To 109
If Cells(r - 1, c).Value = "" Then
Cells(r, c).Copy Cells(r - 1, c)
Cells(r, "D").Value = "To Delete"
ElseIf Cells(r - 1, c).Value <> "" Then
Cells(r, c).Copy Cells(r - 1, c + 1)
Cells(r, "D").Value = "To Delete"
End If
Next c
End If
Next r
For d = lr To 3 Step -1
If Cells(d, "D").Value = "To Delete" Then
Cells(d, "D").EntireRow.Delete
End If
Next d
End With
Application.ScreenUpdating = True
End Sub