VBA macro running slow/crashing when autofilling with a UDF

AshG1990

New Member
Joined
Sep 11, 2017
Messages
27
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----------------------------

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:

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Why are you autofilling like that?
 
Upvote 0
I've tried normal autofilling with the whole range, did this way to see if it would be any quicker as then less formula's. Like I said I've tried numerous ways, this is just the latest in my desperate attempts. If I step through it will work no problem, I'm really getting to the end of my tether with it!

Any help would be much appreciated.
 
Upvote 0
Given that you are calling a UDF, have you tried calling it directly in the code rather than using a formula in the cells and then converting that to a value?
 
Upvote 0
You could put a shorter formula in the cell like this:

Code:
"=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"","""")))"

Then, if the cell value is "", you can perform the other tests

Code:
Select case Trim$(Cells(i, "F").Value)
Case "Driver"
Cells(i, "J").Value = G_TIMEDRIVE(Cells(i - 1, "E").value, Cells(i, "E").value, "Decimal") * 60
case "Public Transport"
Cells(i, "J").Value = G_TIMEPUBLIC(Cells(i - 1, "E").value, Cells(i, "E").value, "Decimal") * 60
case "Walker"
Cells(i, "J").Value = G_TIMEWALK(Cells(i - 1, "E").value, Cells(i, "E").value, "Decimal") * 60
end select

for example.
 
Upvote 0
I didn't do the whole function but I think Rory is talking about something like this:

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.Value = WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(Cell.Row, 1)), Cells(Cell.Row, 1).Value)
    Next Cell
    
    For i = 2 To LR
        If i = 2 Then
            Cells(i, 10).Value = "N/A - First Client"
        ElseIf Cells(i, 14).Value = WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(LR, 2)), Cells(i, 1).Value) Then
            Cells(i, 10).Value = "N/A - Last Client"
        ElseIf Cells(i, 6).Value = "" Then
            Cells(i, 10).Value = "Error - No transport mode present"
        Else
            Select Case Trim(Cells(i, 6).Value)
                Case "Driver"
                    Cells(i, 10).Value = G_TIMETAKEN(Cells(i - 1, 5).Value, Cells(i, 5).Value, "D", "Decimal")
                Case "Public Transport"
                    Cells(i, 10).Value = G_TIMETAKEN(Cells(i - 1, 5).Value, Cells(i, 5).Value, "T", "Decimal")
                Case "Walker"
                    Cells(i, 10).Value = G_TIMETAKEN(Cells(i - 1, 5).Value, Cells(i, 5).Value, "W", "Decimal")
                Case Else
                    Cells(i, 10).Value = ""
            End Select
        End If
        If i Mod 20 = 0 Then
            Application.Wait (Now + TimeValue("00:00:05"))
        End If
    Next i
    
    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 G_TIMETAKEN(Origin As String, Destination As String, Mode 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
Dim myUrl As String
    Application.ScreenUpdating = False
    
    G_TIMETAKEN = 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
    myUrl = "http://maps.googleapis.com/maps/api/directions/xml?origin=" & Origin & "&destination=" & Destination
    If Mode = "T" Then
        myUrl = myUrl & "&mode=transit"
    ElseIf Mode = "W" Then
        myUrl = myUrl & "&mode=walking"
    End If
    myUrl = myUrl & "&sensor=false"
    myRequest.Open "GET", myUrl, 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_TIMETAKEN = timeNode.Text / 3600 ' Seconds in an hour
    Else 'Return in Excel's 00:00:00 date format - 30 mins as 00:30:00
        G_TIMETAKEN = 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

Note that I converted your three functions for time calculation into a single one with a parameter for the mode. I haven't tested this as I don't have sample data.

WBD
 
Upvote 0
Thanks very much Rory, I'll give it a go and keep you updated. Thanks too Dixon.
 
Last edited:
Upvote 0
Tried both of your suggestions, it is still doing the same unfortunately :/

Any ideas?

Regards,

Ash
 
Upvote 0
Perhaps it’s Google limiting the number of calls that can be made in a certain timeframe.
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top