Hi,
I need to a turnaround today if possible please. Thanks in advance.
I have a file that runs a macro, the macro is taking far too long to execute. However, if I step through the macro it works as quickly as it should stepping through.
It slows down once it hits the Autofill part of the "TimeAnalysis" macro, it is basically entering a formula into the cell (formula is from a UDF I have written), it then copies it down. I've tried numerous different ways to perform this including .formula etc...
Below is the macro code and the function code is below that. It is on a file of approximately 900 rows.
Regards,
Ash
--------------Macro Here----------------------------
-------------------Function Here -------------------------------------------
I need to a turnaround today if possible please. Thanks in advance.
I have a file that runs a macro, the macro is taking far too long to execute. However, if I step through the macro it works as quickly as it should stepping through.
It slows down once it hits the Autofill part of the "TimeAnalysis" macro, it is basically entering a formula into the cell (formula is from a UDF I have written), it then copies it down. I've tried numerous different ways to perform this including .formula etc...
Below is the macro code and the function code is below that. It is on a file of approximately 900 rows.
Regards,
Ash
--------------Macro Here----------------------------
Code:
Option Explicit
Sub TimeAnalysis()
Dim MainFile As Workbook
Dim Cell As Range
Dim LR As Long, ErrorRow As Long, ErrorLR As Long, i As Long
Dim V1 As Variant, V2 As Variant, V3 As Variant
Set MainFile = ThisWorkbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayStatusBar = False
End With
ActiveSheet.DisplayPageBreaks = False
V1Entry:
V1 = InputBox("Please enter a value for V1 (Schedule Gap Minutes):", "V1 Value", " ")
If V1 = "" Or V1 = " " Then
MsgBox "You must enter a value for V1!", vbCritical, "Error"
GoTo V1Entry
Else
If Not IsNumeric(V1) Then
MsgBox "Must be a numeric value only!", vbCritical, "Error"
GoTo V1Entry
End If
End If
V2Entry:
V2 = InputBox("Please enter a value for V2 (Hourly Rate):", "V2 Value", " ")
If V2 = "" Or V2 = " " Then
MsgBox "You must enter a value for V2!", vbCritical, "Error"
GoTo V2Entry
Else
If Not IsNumeric(V2) Then
MsgBox "Must be a numeric value only!", vbCritical, "Error"
GoTo V2Entry
End If
End If
V3Entry:
V3 = InputBox("Please enter a value for V3 (Living Wage):", "V3 Value", " ")
If V3 = "" Or V3 = " " Then
MsgBox "You must enter a value for V3!", vbCritical, "Error"
GoTo V3Entry
Else
If Not IsNumeric(V3) Then
MsgBox "Must be a numeric value only!", vbCritical, "Error"
GoTo V3Entry
End If
End If
MsgBox "This may take up to 15 minutes, please be patient!", vbInformation, "Information"
Sheets("Output - Detailed Report").Activate
Range("N1").Value = "Count"
LR = Range("A" & Rows.Count).End(xlUp).Row
For Each Cell In Range("N2:N" & LR)
Cell.Formula = "=countif($A$2:" & Cell.Offset(0, -13).Address(False, False) & "," & Cell.Offset(0, -13).Address(False, False) & ")"
ActiveSheet.Calculate
Cell.Copy
Cell.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next Cell
Range("J2").Formula = "=IF(N2=1,""N/A - First Client"",IF(N2=COUNTIF($A$2:A" & LR & ",A2),""N/A - Last Client"",IF(F2="""",""Error - No transport mode present"",IF(TRIM(F2)=""Driver"",G_TIMEDRIVE(E1,E2,""Decimal"")*60,IF(TRIM(F2)=""Public Transport"",G_TIMEPUBLIC(E1,E2,""Decimal"")*60,IF(TRIM(F2)=""Walker"",G_TIMEWALK(E1,E2,""Decimal"")*60))))))"
''''''Slows down here and crashes
i = 3
Do Until i = LR + 1
Range("J" & i - 1).AutoFill Range("J" & i - 1 & ":J" & i), xlFillDefault
If i Mod 20 = 0 Then
Application.Wait (Now + TimeValue("00:00:05"))
End If
Range("J" & i - 1).Value = Range("J" & i - 1).Value
i = i + 1
Loop
Stop
For Each Cell In Range("J2:J" & LR)
If Cell.Offset(-1, -5).Value = Cell.Offset(0, -5).Value Then
GoTo NextCell
End If
If Cell.Value = 0 Then
'If WorksheetFunction.IfError(WorksheetFunction.Find(" ", Cell.Offset(-1, -5), 1), 0) > 0 Then
' Cell.Offset(-1, -5).Value = WorksheetFunction.Substitute(Cell.Offset(-1, -5), " ", "")
'Else
' Cell.Offset(-1, -5).Value = Left(Cell.Offset(-1, -5), Len(Cell.Offset(-1, -5)) - 3) & " " & Right(Cell.Offset(-1, -5), 3)
' End If
'If Cell.Value = 0 Then
' If WorksheetFunction.IfError(WorksheetFunction.Find(" ", Cell.Offset(0, -5), 1), 0) > 0 Then
' Cell.Offset(0, -5).Value = WorksheetFunction.Substitute(Cell.Offset(0, -5), " ", "")
' End If
'Else
' Cell.Offset(0, -5).Value = Left(Cell.Offset(0, -5), Len(Cell.Offset(0, -5)) - 3) & " " & Right(Cell.Offset(0, -5), 3)
'End If
'If Cell.Value = 0 Then
' If WorksheetFunction.IfError(WorksheetFunction.Find(" ", Cell.Offset(-1, -5), 1), 0) > 0 Then
' Cell.Offset(-1, -5).Value = WorksheetFunction.Substitute(Cell.Offset(-1, -5), " ", "")
' End If
'Else
' Cell.Offset(-1, -5).Value = Left(Cell.Offset(-1, -5), Len(Cell.Offset(-1, -5)) - 3) & " " & Right(Cell.Offset(-1, -5), 3)
'End If
'If Cell.Value = 0 Then
ErrorRow = Cell.Row
Sheets("Error Log").Activate
ErrorLR = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & ErrorLR + 1).Value = MainFile.Name
Range("B" & ErrorLR + 1).Value = ErrorRow
Range("C" & ErrorLR + 1).Value = "Postcode(s) not found."
'End If
End If
NextCell:
Next Cell
For Each Cell In Range("K2:K" & LR)
If Cell.Offset(0, -2).Value <= V1 Then
Cell.Value = Cell.Offset(0, -2).Value + Cell.Offset(0, -1).Value
Else
Cell.Value = Cell.Offset(0, -2).Value
End If
Next Cell
For Each Cell In Range("L2:L" & LR)
Cell.Value = Cell.Offset(0, -3).Value / 60 * V2 / Cell.Offset(0, -1).Value / 60
Next Cell
For Each Cell In Range("M2:M" & LR)
If Cell.Offset(0, -1).Value > V3 Then
Cell.Value = "Y"
Else
With Cell
.Value = "N"
.Font.Bold = True
.Font.Color = vbRed
End With
End If
Next Cell
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayStatusBar = True
End With
ActiveSheet.DisplayPageBreaks = True
MsgBox "Analysis complete :)", vbInformation, "Analysis Complete"
End Sub
-------------------Function Here -------------------------------------------
Code:
Option Explicit
Function G_TIMEDRIVE(Origin As String, Destination As String, _
Optional Format As String = "Date") As Double
' Requires a reference to Microsoft XML, v6.0
' Draws on the stackoverflow answer at bit.ly/parseXML
Dim myRequest As XMLHTTP60
Dim myDomDoc As DOMDocument60
Dim timeNode As IXMLDOMNode
Application.ScreenUpdating = False
G_TIMEDRIVE = 0
On Error GoTo exitRoute
' Check and clean inputs
Origin = Replace(Origin, " ", "%20")
Destination = Replace(Destination, " ", "%20")
' Read the XML data from the Google Maps API
Set myRequest = New XMLHTTP60
myRequest.Open "GET", "http://maps.googleapis.com/maps/api/directions/xml?origin=" _
& Origin & "&destination=" & Destination & "&sensor=false", False
myRequest.send
' Make the XML readable usign XPath
Set myDomDoc = New DOMDocument60
myDomDoc.LoadXML myRequest.responseText
' Get the time node value
Set timeNode = myDomDoc.SelectSingleNode("//leg/duration/value")
If Format = "Decimal" Then ' Return as a decimal - 30 mins as 0.5 hrs
G_TIMEDRIVE = timeNode.Text / 3600 ' Seconds in an hour
Else 'Return in Excel's 00:00:00 date format - 30 mins as 00:30:00
G_TIMEDRIVE = timeNode.Text / 86400 ' Seconds in a day
End If
exitRoute:
' Tidy up
Set timeNode = Nothing
Set myDomDoc = Nothing
Set myRequest = Nothing
Application.ScreenUpdating = False
End Function
Function G_TIMEWALK(Origin As String, Destination As String, _
Optional Format As String = "Date") As Double
' Requires a reference to Microsoft XML, v6.0
' Draws on the stackoverflow answer at bit.ly/parseXML
Dim myRequest As XMLHTTP60
Dim myDomDoc As DOMDocument60
Dim timeNode As IXMLDOMNode
Application.ScreenUpdating = False
G_TIMEWALK = 0
On Error GoTo exitRoute
' Check and clean inputs
Origin = Replace(Origin, " ", "%20")
Destination = Replace(Destination, " ", "%20")
' Read the XML data from the Google Maps API
Set myRequest = New XMLHTTP60
myRequest.Open "GET", "http://maps.googleapis.com/maps/api/directions/xml?origin=" _
& Origin & "&destination=" & Destination & "&mode=" & "walking" & "&sensor=false", False
myRequest.send
' Make the XML readable usign XPath
Set myDomDoc = New DOMDocument60
myDomDoc.LoadXML myRequest.responseText
' Get the time node value
Set timeNode = myDomDoc.SelectSingleNode("//leg/duration/value")
If Format = "Decimal" Then ' Return as a decimal - 30 mins as 0.5 hrs
G_TIMEWALK = timeNode.Text / 3600 ' Seconds in an hour
Else 'Return in Excel's 00:00:00 date format - 30 mins as 00:30:00
G_TIMEWALK = timeNode.Text / 86400 ' Seconds in a day
End If
exitRoute:
' Tidy up
Set timeNode = Nothing
Set myDomDoc = Nothing
Set myRequest = Nothing
Application.ScreenUpdating = False
End Function
Function G_TIMEPUBLIC(Origin As String, Destination As String, _
Optional Format As String = "Date") As Double
' Requires a reference to Microsoft XML, v6.0
' Draws on the stackoverflow answer at bit.ly/parseXML
Dim myRequest As XMLHTTP60
Dim myDomDoc As DOMDocument60
Dim timeNode As IXMLDOMNode
Application.ScreenUpdating = False
G_TIMEPUBLIC = 0
On Error GoTo exitRoute
' Check and clean inputs
Origin = Replace(Origin, " ", "%20")
Destination = Replace(Destination, " ", "%20")
' Read the XML data from the Google Maps API
Set myRequest = New XMLHTTP60
myRequest.Open "GET", "http://maps.googleapis.com/maps/api/directions/xml?origin=" _
& Origin & "&destination=" & Destination & "&mode=" & "transit" & "&sensor=false", False
myRequest.send
' Make the XML readable usign XPath
Set myDomDoc = New DOMDocument60
myDomDoc.LoadXML myRequest.responseText
' Get the time node value
Set timeNode = myDomDoc.SelectSingleNode("//leg/duration/value")
If Format = "Decimal" Then ' Return as a decimal - 30 mins as 0.5 hrs
G_TIMEPUBLIC = timeNode.Text / 3600 ' Seconds in an hour
Else 'Return in Excel's 00:00:00 date format - 30 mins as 00:30:00
G_TIMEPUBLIC = timeNode.Text / 86400 ' Seconds in a day
End If
exitRoute:
' Tidy up
Set timeNode = Nothing
Set myDomDoc = Nothing
Set myRequest = Nothing
Application.ScreenUpdating = False
End Function
Last edited by a moderator: