VBA macro running slow/crashing when autofilling with a UDF

A

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:
Sort by date Sort by votes
I read about this, but why would it crash it out? Also if I do a formula in J2 and manually autofill it within Excel, it works fine, as soon as I automate the process it trips up. Is there any way around this or any alternative solutions you could help me with?

Regards,

Ash
 
Last edited:
Upvote 0

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sorry but I really can't help without having the actual data and being able to run and debug the code.

WBD
 
Upvote 0
Okay, is there any way I can post the file here or do you have an email you can PM me? It'd be really appreciated.

Regards,

Ash
 
Upvote 0
RoryA said:
Perhaps it’s Google limiting the number of calls that can be made in a certain timeframe.
Click to expand...

Can confirm crashing after filling in the so-called G_Distance formula.
I've got a very simple macro that takes two postal codes and city names and adds the G_Distance formula (Google Distance) in an adjacent cell.
All goes well until I have filled in about 50 to 100 distances, then Excel crashes and there is only Ctrl-Alt-Del to get out of it.

I build in a loop to save every 10 instances so that at least I have the latest results instead of losing everything.
I tried several things, including adding some Wait or Sleep, but it crashes every time...
 
Upvote 0
Have you tried writing the equations in for each line rather than doing an autofill down.
This method also uses variant array which means it only writes to the spreadsheet once which will be much faster. Note I not sure whether I have modified your equation correctly because i can't test it but it shows you how to do it.
Code: 
ReDim outarr(1 To LR + 1, 1 To 1)

    i = 3
    For i = 3 To LR + 1
      outarr(i, 1) = "=IF(N" & i & "=1,""N/A - First Client"",IF(N" & i & " =COUNTIF($A$2:A" & LR & ",A" & i & "),""N/A - Last Client"",IF(F" & i & "="""",""Error - No transport mode present"",IF(TRIM(F" & i & ")=""Driver"",G_TIMEDRIVE(E" & i & ",E" & i & ",""Decimal"")*60,IF(TRIM(F" & i & ")=""Public Transport"",G_TIMEPUBLIC(E" & i - 1 & ",E" & i & ",""Decimal"")*60,IF(TRIM(F" & i & ")=""Walker"",G_TIMEWALK(E" & i - 1 & ",E" & i & ",""Decimal"")*60))))))"
    Next i
    Range("J1:J" & LR + 1).Formula = outarr
 
Upvote 0
Yes I do. After each line I even wait for 3 seconds to give the google formula the chance to find a solution, otherwise I get a lot of zeroes.
 
Upvote 0
After each line I even wait for 3 seconds to give the google formula the chance to find a solution
Click to expand...
The solution I was proposing only writes to the worksheet once and does all the lines in one go, so you would only need to wait after the macro has finished for the google function to come up with the goods

I do wonder whether the way you are trying to do this with accessing the Google internet facilities using a function is the best way rather than directly within VBA where you have much more control of what is happening
 
Upvote 0
You must log in or register to reply here.

Similar threads

Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
338
Agnarr
Agnarr
D
  • Question
Problems Encountered When Generating VBA Excel Charts with 15-Minute Interval Data.
Replies
0
Views
140
dilshod_k
D
C
  • Question
Postcode finder in Excel and caculate the distance between two postcodes
Replies
0
Views
4K
chao chao
C
M
  • Question
Distance between UK postcodes
Replies
1
Views
4K
John_w
J
E
  • Solved
[VBA] File saving does not work/new version not uploaded
Replies
4
Views
489
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,214,642
Messages
6,120,701
Members
448,980
Latest member
CarlosWin

Share this page

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