Speeding-Up a VBA Script

[Nameless_87]

Hello All,

This will probably be an easy request for you.

I am currently running a script that filters a rather large report I run to a manageable size. It runs from around 40000-50000 rows down to 2000-5000.
Is there any way of speeding the script up? It takes about 20 mins to run currently.</SPAN></SPAN>

Sub SortReport()
'
' SortReport Macro
Workbooks.Open Filename:="*Selected Drive*\Exported Reports.xls"

Application.ScreenUpdating = False 'These two bits of code speed up the macro
'Application.Calculation = xlManual

Cells.Select
Selection.Copy
Windows("Candidate Checker V3.xlsm").Activate
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("B:H").Select
Columns("B:H").EntireColumn.AutoFit 'Formatas data in range

'We need to consolicate the candidate columns here
Sheets("Sheet2").Select
'Insert new column for Concatenating First Name and Last Name:
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Insert the concatenate formula:
Range("C2:C50000").Select

'Format range as general to allow formula to be entered:
Selection.NumberFormat = "General"
ActiveCell.Formula = Formula 'R1C1 = ""

Range("C4").Select

'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2],"" "",RC[-1])"
ActiveCell.Formula = "=CONCATENATE(RC[-1],"" "",RC[-2])"
Range("C4").Select
'filldown:
Selection.AutoFill Destination:=Range("C4:C50000") 'unable to find working code to filldown dynamic range:
'Range("C2").AutoFill Destination:=Range("C2:C" & Lastrow)? This seems to screw up the macro
Range("C4:C50000").Select

'Enter column heading, and autofit:
Range("C3").Select
ActiveCell.FormulaR1C1 = "Full Name"
Columns("C:C").EntireColumn.AutoFit

'Copy concatenated names, then overwrite with Paste Values:
Range("C4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False



Windows("Exported Reports.xls").Activate
Application.DisplayAlerts = False
ActiveWindow.Close SaveChanges = False

Columns("C:C").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A2").Select
Selection.AutoFilter

'Filter Names
Dim v As Variant
'There are a roughly 350 FullNames
v = Application.Transpose(Range("FullNames"))
Range("A2").Select
Selection.AutoFilter Field:=1, Criteria1:=v, Operator:=xlFilterValues



Dim Firstrow As Long ' This section removes courses and any sessions not wanted
Dim LastRow As Long ' by deleting the black rows
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With Sheets("sheet2")
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = LastRow To Firstrow Step -1
'We check the values in the B column in this example

With .Cells(Lrow, "F")

If Not IsError(Application.Match(.Value, _
Sheets("Candidates").Range("Cancelled"), 0)) Then .EntireRow.Delete

End With

With .Cells(Lrow, "D")
' The "NotRequired" list is roughly 1650 lines
If Not IsError(Application.Match(.Value, _
Sheets("Candidates").Range("NotRequired"), 0)) Then .EntireRow.Delete

End With

With .Cells(Lrow, "D")

If IsEmpty(.Value) Then .EntireRow.Delete
'This will delete the row if the cell is empty
End With

Next Lrow
End With

ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode


End With

Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("B5").Select
ActiveSheet.Paste
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").ColumnWidth = 8.5
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Sheets("Sheet2").Select
Selection.AutoFilter
Sheets("Sheet1").Select
Application.Calculation = xlAutomatic 'This closes the speed of editing
Application.ScreenUpdating = True

End Sub

 

[Trevor G]

Have you considered also stop the screen warnings from being displayed? What happens if you copy the workbook to a local drive run it from there and then copy back to server drive.

Application.DisplayAlerts=False

 

[Nameless_87]

Hi Trevor,

I will not be able to copy it to my own drive as i may not be running it, it is set up so anyone can do my reporting if I am away. Moving it to the person running the scripts drive will cause confusion as the script locations will need to change each time. Although I may look into this if it cannot be done.

Also I do have Application.DisplayAlerts=False, in the script round the middle of it.

It may not be possible to speed the script up due to its size. Just wondered it could be done by editing the code in place.

Thanks for your suggestions Trevor :+)

 

[Snakehips]

Nameless_87,

Many of us record macros to form the basis of ongoing code and the code above would appear to have started out that way. Recorded code is generally not the most efficient for various reasons one of which is that every keystroke is recorded, every selection every scroll etc. Parts of your code contains a lot of 'selections' and then work with the selection. I don't know whether there is much time to be saved in the running of your process but it may be worth looking at removing all the u necessary selections.

Some examples of streamlining might be....


Can you copy the initial sheet data into Candidate Checker from within by doing a sheet copy like

Windows("Exported Reports.xls").Activate
        Sheets("Sheet2").Copy Before:=Workbooks("Book1").Sheets(1)
        Range("A:A,D:D").Delete  'D would be C as below if deleted 1 col at a time
        Columns("B:H").EntireColumn.AutoFit 'Formatas data in range

Rather than

Cells.Select
Selection.Copy
Windows("Candidate Checker V3.xlsm").Activate
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("B:H").Select
Columns("B:H").EntireColumn.AutoFit 'Formatas data in range

Also...

LastRow = Cells(Rows.Count, 3).End(xlUp).Row     'edit 3 (col c) if need to be any other column
Range("C2:C" & LastRow).NumberFormat = "General"
ActiveCell.Formula = Formula  = ""
Range("C4:C" & LastRow).Formula = "=CONCATENATE(RC[-1],"" "",RC[-2])"

Rather than..

'Insert the concatenate formula:
Range("C2:C50000").Select

'Format range as general to allow formula to be entered:
Selection.NumberFormat = "General"
ActiveCell.Formula = Formula 'R1C1 = ""

Range("C4").Select

'ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2],"" "",RC[-1])"
ActiveCell.Formula = "=CONCATENATE(RC[-1],"" "",RC[-2])"
Range("C4").Select
'filldown:
Selection.AutoFill Destination:=Range("C4:C50000") 'unable to find working code to filldown dynamic range:
'Range("C2").AutoFill Destination:=Range("C2:C" & Lastrow)? This seems to screw up the macro
Range("C4:C50000").Select

Just thoughts, and not tested.

Hope that helps.

 

[Snakehips]

Nameless,

Just another thought occurs. Not thought through properly because I am busy and due out shortly.

If you have 40000 / 50000 rows that at one point you are stepping through and doing a match eg in Candidates Not required which has 1650 rows. Can you not turn that round the other way and step through the 1650 for a match in the bigger list?

Another small eg, for fixing the full names after adding the formula...
Perhaps

Enter column heading, and autofit:
Range("C3") = "Full Name"
Columns("C:C").EntireColumn.AutoFit
Range("C4:C"&LastRow).Value = Range("C4:C"&LastRow).Value 

Rather than

Enter column heading, and autofit:
Range("C3").Select
ActiveCell.FormulaR1C1 = "Full Name"
Columns("C:C").EntireColumn.AutoFit

'Copy concatenated names, then overwrite with Paste Values:
Range("C4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

 

[Nameless_87]

Snakehips,

Thanks for the advice, the code seems to be quicker, however I think the amount of data it has to go through several times just makes it impossible speed up that much (just means ill have to go make a cuppa while i wait ;+).)

I have also started to thin the code out and get rid of unneeded key strokes.

Thanks again for the advice!

 

[Snakehips]

Nameles,

How much do you want to preserve that 20 minute cuppa break?

I think that the code below, suitably tweaked, will save significant run time.

It requires using a 'helper column which I have assumed as column M.

You can avoid the time costly, row by row loop by populating M with the match formulas such that matches produce blanks and N/A's produce a nominal value (100). You can then do a SpecialCells (Blank) and delete rows on that basis. Repeat for both matches and then just do the SpecialCells blank delete on column D.

This should process in seconds rather than minutes.

So roughly, replace this....

Dim Firstrow As Long ' This section removes courses and any sessions not wanted
Dim LastRow As Long ' by deleting the black rows
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With Sheets("sheet2")
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = LastRow To Firstrow Step -1
'We check the values in the B column in this example

With .Cells(Lrow, "F")

If Not IsError(Application.Match(.Value, _
Sheets("Candidates").Range("Cancelled"), 0)) Then .EntireRow.Delete

End With

With .Cells(Lrow, "D")
' The "NotRequired" list is roughly 1650 lines
If Not IsError(Application.Match(.Value, _
Sheets("Candidates").Range("NotRequired"), 0)) Then .EntireRow.Delete

End With

With .Cells(Lrow, "D")

If IsEmpty(.Value) Then .EntireRow.Delete
'This will delete the row if the cell is empty
End With

Next Lrow
End With

ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode


End With

With this..

Range("M1:M50000").FormulaR1C1 = "=IF(ISNA(MATCH(RC[-7],Cancelled,0)),100,"""")"  'Works on col F from formula in M
Range("M1:M50000").Value = Range("M1:M50000").Value
On Error Resume Next
Range("m1:m50000").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Range("M1:M50000").FormulaR1C1 = "=IF(ISNA(MATCH(RC[-9],NotRequired,0)),100,"""")"  'Works on col D from formula in M
Range("M1:M50000").Value = Range("M1:M50000").Value
On Error Resume Next
Range("M1:M50000").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
On Error Resume Next
Range("M1:M50000").Cells.ClearContents

Range("D1:D50000").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete  'Just special cells blank on D
On Error GoTo 0

Hope that helps.