I’m running Excel version 2408. The following code populates two tables using a query connection and then adds some hyperlinks. The hyperlinks are added correctly for the first table (tblNoStop) but not for the second (tblNoOffice).
If I put a break before the loop that populates the hyperlinks for the second table and then hit F5 from the debugger, everything works fine.
I have tried adding the DoEvents instruction and forced a wait time of up to one minute, but no success.
I also tried commenting out the first loop, but the result is the same: hyperlinks in table tblNoOffice are only added in debug mode.
Does anybody have an idea?
Here is the relevant part of my code:
'For each liine of the tables update hyperlinks
For RowCounter = 1 To tblNoStop.ListRows.Count
'Add link to the staff details in the ADAM web application
Set HLRange = tblNoStop.DataBodyRange(RowCounter, NOSTOP_INDEXCOLIND)
Call AddHL(HLRange, _
wsNoStop, _
"https://adam.unctad.unctad.org/StaffDetails.aspx?id=" & tblNoStop.DataBodyRange(RowCounter, NOSTOP_INDEXCOLIND).Value & "&activemenu=1", _
"", _
SCRTIP & tblNoStop.DataBodyRange(RowCounter, NOSTOP_FIRSTNAMECOLIND).Text & " " & tblNoStop.DataBodyRange(RowCounter, NOSTOP_LASTNAMECOLIND) & ADAMWEB)
'Add link to the staff requests' list in the ADAM web application
Set HLRange = tblNoStop.DataBodyRange(RowCounter, NOSTOP_STOPACCCOLIND)
Call AddHL(HLRange, _
wsNoStop, _
"https://adam.unctad.unctad.org/RequestList.aspx?id=" & tblNoStop.DataBodyRange(RowCounter, NOSTOP_INDEXCOLIND).Value & "&activemenu=1", _
"", _
SCRTIP & tblNoStop.DataBodyRange(RowCounter, NOSTOP_FIRSTNAMECOLIND).Text & " " & tblNoStop.DataBodyRange(RowCounter, NOSTOP_LASTNAMECOLIND) & ADAMREQ)
'Add link to the staff's equipment assignment history
Set HLRange = tblNoStop.DataBodyRange(RowCounter, NOSTOP_FIRSTNAMECOLIND)
Call AddHL(HLRange, _
wsNoStop, _
"https://adam.unctad.unctad.org/itinventory/EquipmentAssignment.aspx?id=" & tblNoStop.DataBodyRange(RowCounter, NOSTOP_INDEXCOLIND).Value & "&type=2&search=h", _
"", _
SCRTIP & tblNoStop.DataBodyRange(RowCounter, NOSTOP_FIRSTNAMECOLIND).Text & " " & tblNoStop.DataBodyRange(RowCounter, NOSTOP_LASTNAMECOLIND) & ADAMASS)
Next
Set tblNoOffice = wsNoStop.ListObjects("NoOffice")
wsNoStop.Activate
DoEvents
'Application.Wait (Now + TimeValue("00:01:05"))
For RowCounter = 1 To tblNoOffice.ListRows.Count
'Add link to the staff details in the ADAM web application
Set HLRange = tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_INDEXCOLIND)
Call AddHL(HLRange, _
wsNoStop, _
"https://adam.unctad.unctad.org/StaffDetails.aspx?id=" & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_INDEXCOLIND).Value & "&activemenu=1", _
"", _
SCRTIP & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_FIRSTNAMECOLIND).Text & " " & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_LASTNAMECOLIND) & ADAMWEB)
DoEvents
'Add link to the staff requests' list in the ADAM web application
Set HLRange = tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_ADACCEXPCOLIND)
Call AddHL(HLRange, _
wsNoStop, _
"https://adam.unctad.unctad.org/RequestList.aspx?id=" & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_INDEXCOLIND).Value & "&activemenu=1", _
"", _
SCRTIP & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_FIRSTNAMECOLIND).Text & " " & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_LASTNAMECOLIND) & ADAMREQ)
'Add link to the staff's equipment assignment history
Set HLRange = tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_FIRSTNAMECOLIND)
Call AddHL(HLRange, _
wsNoStop, _
"https://adam.unctad.unctad.org/itinventory/EquipmentAssignment.aspx?id=" & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_INDEXCOLIND).Value & "&type=2&search=h", _
"", _
SCRTIP & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_FIRSTNAMECOLIND).Text & " " & tblNoOffice.DataBodyRange(RowCounter, NOOFFICE_LASTNAMECOLIND) & ADAMASS)
Next
Sub AddHL(HLRng As Range, Tgtws As Worksheet, tgtAddr As String, SubAddr As String, SCRTIP As String, Optional DispTxt As Variant)
'Colours list can be found at http://dmcritchie.mvps.org/excel/colors.htm
On Error GoTo ErrHandler
If IsMissing(DispTxt) Then
Tgtws.Hyperlinks.Add _
Anchor:=HLRng, _
Address:=tgtAddr, _
SubAddress:=SubAddr, _
ScreenTip:=SCRTIP, _
TextToDisplay:=HLRng.Text
Else
Tgtws.Hyperlinks.Add _
Anchor:=HLRng, _
Address:=tgtAddr, _
SubAddress:=SubAddr, _
ScreenTip:=SCRTIP, _
TextToDisplay:=DispTxt
End If
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox "Error #" & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description, , "Error in subroutine AddHL (Module1)" & _
"", Err.HelpFile, Err.HelpContext
End If
End Sub
9
Thanks to the comment made by @CHill60, I added the line
ThisWorkbook.Connections("Query - NoOffice").OLEDBConnection.BackgroundQuery = False
and the problem disappeared.