Speeding Up Macros

Question

I'm not very experienced with VBA but with some help on SO and plenty of searching I put together this monstrosity

Sub All()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim nRows As Integer: nRows = Cells(Rows.Count, 1).End(xlUp).Row
Dim cell As Range, r As Range: Set r = Range("A2:A" & nRows)
Dim r1 As Range: Set r1 = Range("B2:B" & nRows)
Dim Sel As Range

ActiveSheet.UsedRange.Copy
Sheets.Add.Name = "Original Report"
ActiveSheet.Paste

Application.CutCopyMode = False

'Module1
Worksheets("Sheet1").Activate
ActiveSheet.Cells(1, 1).Select

Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete
Columns(2).EntireColumn.Delete
Columns(3).EntireColumn.Delete
Columns(3).EntireColumn.Delete

ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeLastCell). _
EntireRow.Delete

ActiveSheet.UsedRange.Select
Selection.Replace What:=Chr(160), Replacement:=Chr(32), _
 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
On Error Resume Next
For Each cell In Intersect(Selection, _
    Selection.SpecialCells(xlConstants, xlTextValues))
    cell.Value = Application.Trim(cell.Value)
Next cell
On Error GoTo 0

Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

With ActiveSheet
    .AutoFilterMode = False
    With Range("A1", Range("A" & Rows.Count).End(xlUp))
        .AutoFilter 1, "TOTAL"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
End With


'Module2
Worksheets("Sheet1").Activate
ActiveSheet.Cells(1, 1).Select

For Each cell In r
    If InStr(1, LCase(cell.Value), "customer:") < 1 Then cell.Value = cell.Offset(-1).Value
Next

Columns("I:I").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Columns("B:B").Select
For Each c In Selection.Cells
    If c.Value = vbNullString Then c.Value = 0
Next

For Each cell In r
If InStr(1, LCase(cell.Value), "retenue au projet") > 0 Then
    If Sel Is Nothing Then
        Set Sel = cell
    Else
        Set Sel = Union(Sel, cell)
    End If
End If
Next cell

If Not Sel Is Nothing Then
    With Sel
        .Select
        Selection.EntireRow.Cut
        Sheets.Add.Name = "Temp"
        ActiveSheet.Paste
    End With
End If

Application.CutCopyMode = False

Worksheets("Sheet1").Activate
Rows(1).EntireRow.Copy

Worksheets("Temp").Activate
Rows(1).Insert Shift:=xlDown

Application.CutCopyMode = False

Columns(1).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(2).EntireColumn.Delete


ActiveSheet.UsedRange.Select
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Selection.Columns(1), Order:=xlAscending
.SetRange Selection
.Header = xlYes
.Apply
End With

Range("A1").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True

ActiveSheet.Outline.ShowLevels 2

ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy

Sheets.Add.Name = "Unbilled Holdbacks"
ActiveSheet.Paste

Application.CutCopyMode = False

ActiveSheet.UsedRange.Columns("A").Replace _
What:="Total", Replacement:=vbNullString, _
SearchOrder:=xlByColumns, MatchCase:=True


'Module3
Worksheets("Sheet1").Activate
ActiveSheet.UsedRange.Select

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Selection.Columns(1), Order:=xlAscending
.SortFields.Add Key:=Selection.Columns(2), Order:=xlAscending
.SetRange Selection
.Header = xlYes
.Apply
End With

Range("A1").Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, 7, 8, 9), _
Replace:=False, PageBreaks:=False, SummaryBelowData:=True

For Each cell In r
    If InStr(1, LCase(cell.Value), "customer:") < 1 Then cell.Value = cell.Offset(-1).Value
Next

Columns("B").SpecialCells(xlBlanks).EntireRow.Delete

ActiveSheet.Outline.ShowLevels 2

ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy

Sheets.Add.Name = "Master"
ActiveSheet.Paste

Application.CutCopyMode = False

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Selection.Columns(2), Order:=xlAscending
.SetRange Selection
.Header = xlYes
.Apply
End With

ActiveSheet.UsedRange.Columns("B").Replace _
What:="Total", Replacement:=vbNullString, _
SearchOrder:=xlByColumns, MatchCase:=True

Columns("A").SpecialCells(xlBlanks).EntireRow.Delete

Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Sheets("Temp").Delete
Application.DisplayAlerts = True

ActiveSheet.Cells(1, 1).Select


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

I've finished debugging it and it does what I need it to but it takes a while to run. Does anyone have any pointers on making this more stable/efficient? I've tried clearing the clipboard and reducing the amount of selecting (I know there's still a lot but it was much worse) but in some cases it affected the output and I had to keep the .Select. Any advice on what to work on is much appreciated.

Edit: As to the purpose of the code, it is mainly to take a disorganized data dump and format it a very specific way.

Answer 1

This does not address you code directly but, try stepping away from it and learning how to use objects with some simple tasks on a blank sheet. Then you will understand how to apply them to your code.

Dim ws as Excel.Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")

Then without even activating it or selecting anything on it, you can do anything such as

Work with Ranges

ws.Range("A" & lRow).NumberFormat = "@"
ws.Range("F" & lRow).Value = "SomeText"

if ws.Range("F" & lRow).Value = "somevalue" then
    'Do something
End if

Delete rows

ws.Rows(lRow).EntireRow.Delete

Get the worksheet properties.

Dim str As String
str = ws.name
msgbox (str)

It pretty much goes

Application -> WorkBook -> Worksheet -> Any object on a worksheet

Answer 2

Your code have quite a lot of redundancy. For example:

Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete
Rows(1).EntireRow.Delete

If you are deleting the first 5 rows can be:

Rows("1:5").Delete xlUp

Same goes with the Column part. You can improve as well if you incorporate With Clause.

With Worksheets("Sheet1")
    .Rows("1:5").Delete xlUp
End With

Now, to help you in coding and make Intellisense kick in, set your object in a declared variable.

Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
Dim r As Range, c As Range

With ws
    .Rows("1:5").Delete xlUp
    .Columns("A:B").Delete xlToLeft
    .UsedRange.SpecialCells(xlCellTypeLastCell).EntireRow.Delete
    Set r = .UsedRange
    r.Replace What:=Chr(160), Replacement:=Chr(32), _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    For Each c In Intersect(r, r.SpecialCells(xlConstants, xlTextValues))
        c.Value2 = Application.Trim(c.Value2)
    Next

    '.
    '.
    'and the rest of your coding
End With

Now, I'm not sure if the For Loop is necessary but if you can eliminate that, it may speed things up a bit as well. I have no suggestion for that since I don't know the purpose. I leave it as is.

So in short, tidy up your code a bit. I leave the rest to you.

Answer 3

Application.ScreenUpdating = False

run macro

Application.ScreenUpdating = true