Excel Macro with UDF - Sometimes calculates perfectly but sometimes doesn't

[AshG1990]

I've attached my VBA Macros and the UDF, I've highlighted in yellow example rows of where the time sometimes calculates perfectly, then other times it just adds a 0 in the cell. I'm really not sure what the issue is.

I can also send the file is necessary.

Any help would be much appreciated.

Option Explicit


Function G_TIMETAKEN(Origin As String, Destination As String, Mode As String, StartTime As Long, 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 = True

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" & "&departure_time=" & StartTime
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

Option Explicit


Sub TimeAnalysis()

Dim MainFile As Workbook
Dim Cell As Range, SC As Range
Dim LR As Long, LR2 As Long, ErrorRow As Long, ErrorLR As Long, i As Long, DepartTime As Long, DepartTimeSingle As Long, DepartWeekDay As Long
Dim V1 As Double, V2 As Double, V3 As Double

Sheets("Output - Detailed Report").Activate

Set SC = ActiveCell

Set MainFile = ThisWorkbook

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayStatusBar = False
End With

ActiveSheet.DisplayPageBreaks = False

V1 = Sheets("Home").Range("H5").Value
V2 = Sheets("Home").Range("H8").Value
V3 = Sheets("Home").Range("H11").Value

If V1 = 0 Or V2 = 0 Or V3 = 0 Then
MsgBox "Please fill in all values on the home page before running this analysis!", vbCritical, "Error"
Sheets("Home").Activate
Range("G4").Activate
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayStatusBar = True
End With
ActiveSheet.DisplayPageBreaks = True
Exit Sub
End If

MsgBox "This will take a few minutes, please be patient!", vbInformation, "Information"


Sheets("Output - Detailed Report").Activate
Range("N1").Value = "Count"
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("J2:J" & LR).ClearContents

Range("O2").Formula = "=DATE(YEAR(G2),MONTH(G2),DAY(G2))"
Range("O2").AutoFill Range("O2:O" & LR), xlFillDefault
ActiveSheet.Calculate
Range("O2:O" & LR).Copy
Range("O2").PasteSpecial xlPasteValues
Application.CutCopyMode = False

For Each Cell In Range("N2:N" & LR)
Cell.Formula = "=countifs($A$2:" & Cell.Offset(0, -13).Address(False, False) & "," & Cell.Offset(0, -13).Address(False, False) & ",$O$2:" & Cell.Offset(0, 1).Address(False, False) & "," & Cell.Offset(0, 1).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=COUNTIFS($A$2:A" & LR & ",A2,$O$2:O" & LR & ",O2),""N/A - Last Client"",IF(F2="""",""Error - No transport mode present"","""")))"
Range("J2").AutoFill Range("J2:J" & LR), xlFillDefault
ActiveSheet.Calculate
Range("J2:J" & LR).Copy
Range("J2").PasteSpecial xlPasteValues
Application.CutCopyMode = False

Application.Wait (Now + TimeValue("00:00:08"))
For Each Cell In Range("J2:J" & LR)
If Cell.Value = "N/A - First Client" And Cell.Offset(1, 0).Value <> "N/A - First Client" And Cell.Offset(0, -6).Value <> Cell.Offset(1, -6).Value Then
If WorksheetFunction.RoundDown((Cell.Offset(1, -3).Value - Cell.Offset(0, -2).Value) * 1440, 0) <= V1 Then
If Cell.Offset(0, -2).Value < Now Then
DepartWeekDay = Weekday(Cell.Offset(0, -2).Value, vbMonday)
DepartTimeSingle = DateDiff("s", Left(Cell.Offset(0, -2).Value, 10), Cell.Offset(0, -2).Value, vbMonday)
DepartTime = (DateDiff("s", "01/01/1970", (Date - Weekday(Date, vbTuesday)) + 7 + DepartWeekDay - 1, vbMonday)) + DepartTimeSingle
Else
DepartTime = DateDiff("s", "01/01/1970", Cell.Offset(0, -2).Value, vbMonday)
End If
Select Case Trim$(Cell.Offset(0, -4).Value)
Case "Driver"
Cell.Value = WorksheetFunction.RoundUp(G_TIMETAKEN(Cell.Offset(0, -5).Value, Cell.Offset(1, -5).Value, "D", DepartTime, "Decimal") * 60, 0)
Case "Public Transport"
Cell.Value = WorksheetFunction.RoundUp(G_TIMETAKEN(Cell.Offset(0, -5).Value, Cell.Offset(1, -5).Value, "T", DepartTime, "Decimal") * 60, 0)
Case "Walker"
Cell.Value = WorksheetFunction.RoundUp(G_TIMETAKEN(Cell.Offset(0, -5).Value, Cell.Offset(1, -5).Value, "W", DepartTime, "Decimal") * 60, 0)
End Select
End If
DoEvents
End If
Next Cell

For Each Cell In Range("J2:J" & LR)
If Cell.Row Mod 75 = 0 Then
Application.Wait (Now + TimeValue("00:00:02"))
End If
If Cell.Value = "" Then
If WorksheetFunction.RoundDown((Cell.Offset(1, -3).Value - Cell.Offset(0, -2).Value) * 1440, 0) <= V1 Then
'Here, do now from next available day/time
If Cell.Offset(0, -2).Value < Now Then
DepartWeekDay = Weekday(Cell.Offset(0, -2).Value, vbMonday)
DepartTimeSingle = DateDiff("s", Left(Cell.Offset(0, -2).Value, 10), Cell.Offset(0, -2).Value, vbMonday)
DepartTime = (DateDiff("s", "01/01/1970", (Date - Weekday(Date, vbTuesday)) + 7 + DepartWeekDay - 1, vbMonday)) + DepartTimeSingle
Else
DepartTime = DateDiff("s", "01/01/1970", Cell.Offset(0, -2).Value, vbMonday)
End If
Select Case Trim$(Cell.Offset(0, -4).Value)
Case "Driver"
Cell.Value = WorksheetFunction.RoundUp(G_TIMETAKEN(Cell.Offset(0, -5).Value, Cell.Offset(1, -5).Value, "D", DepartTime, "Decimal") * 60, 0)
Case "Public Transport"
Cell.Value = WorksheetFunction.RoundUp(G_TIMETAKEN(Cell.Offset(0, -5).Value, Cell.Offset(1, -5).Value, "T", DepartTime, "Decimal") * 60, 0)
Case "Walker"
Cell.Value = WorksheetFunction.RoundUp(G_TIMETAKEN(Cell.Offset(0, -5).Value, Cell.Offset(1, -5).Value, "W", DepartTime, "Decimal") * 60, 0)
End Select
End If
DoEvents
End If
Next Cell
Application.Wait (Now + TimeValue("00:00:08"))
For Each Cell In Range("J2:J" & LR)
If Cell.Offset(0, -5).Value = Cell.Offset(1, -5).Value Then
GoTo NextCell
End If
If Not IsNumeric(Cell.Value) Then
GoTo NextCell
End If
If Cell.Value = 0 And WorksheetFunction.RoundDown((Cell.Offset(1, -3).Value - Cell.Offset(0, -2).Value) * 1440, 0) <= V1 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
With Sheets("Error Log")
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."
.Rows("2:" & ErrorLR).RowHeight = 14.4
End With
'End If
End If
NextCell:
Next Cell

For Each Cell In Range("J2:J" & LR)
If Cell.Value = "" Then
Cell.Value = 0
End If
Next Cell

For Each Cell In Range("K2:K" & LR)
If Not IsNumeric(Cell.Offset(0, -1).Value) Then
Cell.Value = Cell.Offset(0, -2).Value
Else
Cell.Value = Cell.Offset(0, -2).Value + Cell.Offset(0, -1).Value
End If
Next Cell


For Each Cell In Range("L2:L" & LR)
On Error GoTo -1
On Error GoTo RateError
Cell.Value = WorksheetFunction.RoundUp(Cell.Offset(0, -3).Value / 60 * V2 / (Cell.Offset(0, -1).Value / 60), 2)
RateError:
Next Cell

For Each Cell In Range("M2:M" & LR)
If Cell.Offset(0, -1).Value > V3 Then
With Cell
.Value = "Y"
.Font.Bold = False
.Font.Color = vbBlack
End With
Else
With Cell
.Value = "N"
.Font.Bold = True
.Font.Color = vbRed
End With
End If
Next Cell

Range("N1:N" & LR).ClearContents
Range("O1:N" & LR).ClearContents


With Sheets("Error Log")
ErrorLR = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:C" & ErrorLR).RemoveDuplicates Columns:=3, Header:=xlYes
.Columns("A:C").WrapText = False
.Rows("2:" & ErrorLR).RowHeight = 36.6
.Range("A2:C" & ErrorLR).VerticalAlignment = xlCenter
.Columns("A:C").AutoFit
End With

MsgBox "Analysis complete ", vbInformation, "Analysis Complete"
MsgBox "The Summary Report will now be created!", vbInformation, "Information"

On Error GoTo -1
On Error GoTo 0

Sheets("Output - Summary Report").Activate

LR2 = Range("A" & Rows.Count).End(xlUp).Row
If LR2 > 1 Then
Range("A2:G" & LR2).Delete xlShiftUp
End If

Sheets("Output - Detailed Report").Range("A2:B" & LR).Copy
Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LR2 = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:B" & LR2).RemoveDuplicates Columns:=1, Header:=xlYes

LR2 = Range("A" & Rows.Count).End(xlUp).Row

For Each Cell In Range("C2:C" & LR2)
Cell.Formula = "=sumif('Output - Detailed Report'!A:A," & Cell.Offset(0, -2).Address & ",'Output - Detailed Report'!I:I)"
Cell.NumberFormat = "0"
Cell.Value = Cell.Value
Next Cell

For Each Cell In Range("D2:D" & LR2)
Cell.Formula = "=sumif('Output - Detailed Report'!A:A," & Cell.Offset(0, -3).Address & ",'Output - Detailed Report'!J:J)"
Cell.NumberFormat = "0"
Cell.Value = Cell.Value
Next Cell

For Each Cell In Range("E2:E" & LR2)
Cell.Formula = "=sumif('Output - Detailed Report'!A:A," & Cell.Offset(0, -4).Address & ",'Output - Detailed Report'!K:K)"
Cell.NumberFormat = "0"
Cell.Value = Cell.Value
Next Cell

For Each Cell In Range("F2:F" & LR2)
Cell.Value = WorksheetFunction.RoundUp(Cell.Offset(0, -3).Value / 60 * V2 / (Cell.Offset(0, -1).Value / 60), 2)
Cell.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Next Cell

For Each Cell In Range("G2:G" & LR2)
If Cell.Offset(0, -1).Value > V3 Then
With Cell
.Value = "Y"
.Font.Bold = False
.Font.Color = vbBlack
End With
Else
With Cell
.Value = "N"
.Font.Bold = True
.Font.Color = vbRed
End With
End If
Next Cell

Range("A1").Activate

Sheets("Output - Detailed Report").Activate

SC.Activate

With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayStatusBar = True
End With

ActiveSheet.DisplayPageBreaks = True

MsgBox "Summary Report Created ", vbInformation, "Success"

End Sub

 

[Nutster]

The little things first:

1. Put any VBA code in a [ CODE ] [/CODE ] block. The # in the toolbar does that too. This will preserve your spacing and make it a little easier to read.
2. I tend to put my On Error Goto Handler as the very first line, even before my Dim statements; even Dim statements could raise an error.
3. You don't have to assign local objects with Nothing at the end of a subroutine; the variables will be automatically released when the subroutine ends.

A simpler expression to determine the C/Unix time integer is to put this in a cell:

=([I]CELL[/I]-"1/1/1970")*3600*24

Where CELL is the cell with the the Excel date that you want to convert. Assign the CELL with the Excel time and the cell you put this in will have the Unix time, ready for you to tell Google.

 

[Nutster]

I should have mentioned that I based this answer on this solution on https://www.berezniker.com/content/pages/office/excel-convert-unix-time-excel-time. Credit where credit is due, etc.

 

[AshG1990]

Thanks very much, do you think this will sort my error? I have no idea why sometimes it calculates perfectly and other times it doesn't when the data that I'm testing is exactly the same every time.

 

[Nutster]

Are you sure that the Google API is always returning the same result? Maybe record the result and compare from one run to another to see if you get different results.

 

[AshG1990]

I'm not sure because if I step through the macro on the certain rows it runs fine too, any chance I can send you the file?

Regards,

Ash

 

[AshG1990]

Can anyone help? Maybe take a look at my file, it'd be so greatly appreciated.