Help Cleaning up VBA Code to Run Faster/More Efficient

[chrono2483]

Hello Everyone,

I've been working and building this current script. Currently it averages between 2.5-4 mins to run from beginning to end (sometimes longer). I've searched online and have added such pieces as preventing screen refresh, but still falls within the 2.5-4mins range.

Can anyone recommend some areas were it can be tweaked, to reduce the run time, and still accomplish the intended goal - under a minute would be golden.

Sub SiteCleanUp()
'
' SiteCleanUp Macro
'
' Keyboard Shortcut: Ctrl+j
'

Dim i As Long
Dim l As Long

    ' Prevents screen refreshing.
    Application.ScreenUpdating = False

' On Error GoTo 2

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
'Copy data just as is into new tab to store
    Cells.Select
    Selection.Copy
    Sheets("Hidden Site").Visible = True
    Sheets("Hidden Site").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Hidden Site").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("Paste Here").Select
    

'Unmerge all cells
    Range("A1").Select
        With ActiveSheet
            Cells.UnMerge
        End With

'Remove header rows
    Rows("1:4").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    
'first run to clean columns
    Columns("A:B").Select
    Selection.Delete Shift:=xlUp
    Columns("B:B").Select
    Selection.Delete Shift:=xlUp
    Columns("C:C").Select
    Selection.Delete Shift:=xlUp
    Columns("F:F").Select
    Selection.Delete Shift:=xlUp
    Columns("G:G").Select
    Selection.Delete Shift:=xlUp
    Columns("H:I").Select
    Selection.Delete Shift:=xlUp
    Columns("I:L").Select
    Selection.Delete Shift:=xlUp
    Columns("J:N").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select

'delete all blank rows
'    Application.CutCopyMode = False
    With ActiveSheet
        Rows("1:13000").Select
            For i = Selection.Rows.Count To 1 Step -1
                If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
            Selection.Rows(i).EntireRow.Delete
        End If
        Next i
    End With

'find "Report Data" (where data starts to repeat - delete all rows after
    Dim LastRow As Long, myCell As Range, myRange As Range
    Dim myCell1 As Range
 
    LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row 'find last row
    Set myCell1 = Range("A" & LastRow)
    Cells.Find(What:="Report Data", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False).Activate
    Set myCell = ActiveCell
 
    Set myRange = Range(myCell, myCell1) 'select from last row to current row selected
    myRange.EntireRow.Delete Shift:=xlUp 'delete
' Selection.Delete Shift:=xlUp

'paste data into Working worksheet
   Sheets("Working").Select
    Columns("A:I").Select
    Selection.ClearContents
   
    Sheets("Paste Here").Select
    Range("A3:I" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Working").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    Columns("A:I").EntireColumn.AutoFit
    Range("C1").Select
    Selection.Copy
    Columns("C:C").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "[h]:mm"
   Sheets("Paste Here").Select
    Range("A1").Select

'find "Available" and delete rows
    Dim SrchRng
     
    
    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Available", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing
    
        Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Out", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing
    
    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("After", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Call", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Hold", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Consult", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Inbound", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Personal", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Conference", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Help", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Activities", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Personal", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Task", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Duties", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Total", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Follow Up", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Follow Up", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing

    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set myCell = SrchRng.Find("Face to Face", LookIn:=xlValues)
        If Not myCell Is Nothing Then myCell.EntireRow.Delete
    Loop While Not myCell Is Nothing
    
'autofit
    Columns("A:I").EntireColumn.AutoFit
    
'paste data into Data worksheet
   
Sheets("Data").Select
    Columns("A:I").Select
    Selection.ClearContents
    
    Sheets("Paste Here").Select
    Range("A3:I" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    
'autofit Data worksheet
    Columns("A:I").EntireColumn.AutoFit

'clear M column before pasting

Range("m:n").Clear
Range("EL:JJ").Clear

'copy and paste agent

 Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
 Set myCell = SrchRng.Find("Rep", LookIn:=xlValues)
 If Not myCell Is Nothing Then
 firstAddress = myCell.Address
 i = 3
 myCell.Copy Cells(i, "M")
 Else
 MsgBox "Can't find search string"
 Exit Sub
 End If
 Do
 Set myCell = SrchRng.FindNext(myCell)
 If myCell Is Nothing Then Exit Do
 If myCell.Address = firstAddress Then Exit Do
 i = i + 1
 myCell.Copy Cells(i, "M")
 Loop
  
'copy and paste date

  Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
 Set myCell = SrchRng.Find("Date", LookIn:=xlValues)
 If Not myCell Is Nothing Then
 firstAddress = myCell.Address
 i = 3
 myCell.Copy Cells(i, "N")
 Else
 MsgBox "Can't find search string"
 Exit Sub
 End If
 Do
 Set myCell = SrchRng.FindNext(myCell)
 If myCell Is Nothing Then Exit Do
 If myCell.Address = firstAddress Then Exit Do
 i = i + 1
 myCell.Copy Cells(i, "N")
 Loop
    
    'row to column of agents
    
    Dim iLRow, iStart, iEnd, iCol As Integer

iLRow = Cells(Cells.Rows.Count, 2).End(xlUp).Row
iStart = 1
iEnd = 2
iCol = 142

Do While iEnd <= iLRow + 1
    If Left(Cells(iStart, 1), 5) <> "Rep" Then
        iStart = iStart + 1
        iEnd = iStart + 1
    Else
        If Left(Cells(iEnd, 1), 5) <> "Rep" And iEnd <> iLRow + 1 Then
            iEnd = iEnd + 1
        Else
            Range(Cells(iStart, 1), Cells(iEnd - 1, 9)).Copy
            Cells(1, iCol).PasteSpecial xlPasteAll
            'Range(Cells(iStart, 1), Cells(iEnd - 1, 9)).Clear
            iStart = iEnd
            iEnd = iStart + 1
            iCol = iCol + 9
        End If
    End If
Loop

Application.CutCopyMode = False
    
   
 
    'go back to summary page
 Sheets("What you need").Select
    Range("A1").Select 'go back to summary page
    
 'turn back on updating, auto calculation
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationAutomatic
    End With
   
       'Autosave
FName = "C:\Users\" & VBA.Environ("Username") & "\Desktop\Outdoor Tool\" & Format(Range("BB7"), "mmmm-dd-yyyy") & ".xlsm"
    ActiveWorkbook.SaveAs Filename:=FName, _
                          FileFormat:=xlOpenXMLWorkbookMacroEnabled
     Sheets("Data").Select
     Sheets("What you need").Select
    Range("A3").Select
   
End

2
        With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationAutomatic
    End With
    MsgBox "Error"
  
    ' Enables screen refreshing.
    Application.ScreenUpdating = True
   
   
End Sub

Thank you!

 

[Michael M]

1st tip would be to remove your .Select...Selection lines
for example

Sheets("Data").Select
    Columns("A:I").Select
    Selection.ClearContents

WOULD BE

Sheets("Data").Columns("A:I").ClearContents

 

[mole999]

This is confusing
Columns("A:B").Select
Selection.Delete Shift:=xlUp
Columns("B:B").Select
Selection.Delete Shift:=xlUp
Columns("C:C").Select
Selection.Delete Shift:=xlUp
Columns("F:F").Select
Selection.Delete Shift:=xlUp
Columns("G:G").Select
Selection.Delete Shift:=xlUp
Columns("H:I").Select
Selection.Delete Shift:=xlUp
Columns("I:L").Select
Selection.Delete Shift:=xlUp
Columns("J:N").Select
Selection.Delete Shift:=xlUp

for one xlup is rows

2nd as you delete each column, you then reuse the columns ID

work out all that you want to delete, and use

Columns("A:B,C:C,D:D,F:F").delete as this format, decide from the start which columns to delete and do it all in one go MAKE SURE YOU USE A TEST BOOK

POSSIBLY

Columns("A:B,D:D,F:F,J:J,L:L,O:O,Q:R,T:V").delete

 

[dmt32]

Hi,
have not got time to work through all your code but this section:

 Dim SrchRng
     
    
    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Available", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing
    
        Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Out", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing
    
    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("After", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Call", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Hold", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Consult", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Inbound", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Personal", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Conference", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Help", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Activities", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Personal", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Task", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Duties", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Total", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Follow Up", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Follow Up", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing


    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    Do
        Set mycell = SrchRng.Find("Face to Face", LookIn:=xlValues)
        If Not mycell Is Nothing Then mycell.EntireRow.Delete
    Loop While Not mycell Is Nothing

You repeat a couple of the searches ("Follow Up" & "Personal") but you should be able to to do this in one loop of the range.

Not tested but something like following:

Sub ClearColumn()
'find "Available" and delete rows
    Dim SrchRng As Range, mycell As Range, DeleteRange As Range
    Dim arr As Variant, m As Variant
     
    arr = Array("Available", "Out", "After", "Call", "Hold", "Consult", "Inbound", "Personal", _
                "Conference", "Help", "Activities", "Task", "Duties", "Total", "Face to Face")
    
    Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))
    
    For Each mycell In SrchRng.Cells
    m = Application.Match(mycell.Value, arr, False)
        If Not IsError(m) Then
            If DeleteRange Is Nothing Then
                Set DeleteRange = mycell
            Else
                Set DeleteRange = Union(DeleteRange, mycell)
            End If
        End If
    Next mycell
    'delete all matched rows in one go
    If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete
    
End Sub

Also, avoid using Select in your code.

this for example:

Sheets("Paste Here").Select
    Range("A3:I" & ActiveSheet.Cells.SpecialCells(xlLastCell).Row).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select

could be changed to this:

    With Sheets("Paste Here")
        .Range("A3:I" & .Cells.SpecialCells(xlLastCell).Row).Copy Sheets("Data").Range("A1")
    End With

Dave

 

[mole999]

Another point, make the selections dynamic

ActiveSheet.Range("H13000") will always do 13000 rows, regardless


if you include at the top

Dim LR as Long
Dim sht As Worksheet

Set sht = Activesheet

'Ctrl + Shift + End
LR = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row


and change

ActiveSheet.Range("H13000")
to
ActiveSheet.Range("H"& LR)

 

[dmt32]

whoops in my haste omitted the second range in updated code:

this line:

Set SrchRng = ActiveSheet.Range("H1", ActiveSheet.Range("H13000").End(xlUp))

should be changed to this:

Set SrchRng = Union(Range(Range("H1"), Range("H" & Rows.Count).End(xlUp)), _
                        Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)))

As mentioned by mole999 range should be dynamic rather than fixed - above code has been updated to do this.

Dave