Excel VBA Taking Long Time To Update Hyperlink On Each Cell


Active Member
Oct 26, 2009

I have around 5000 rows data in a sheet, and I am applying a hyperlink in a column where the cell is not blank, it is working fine but it is taking around 1 minute and 20 seconds to update the hyperlink.

Please see the code below.

I have highlighted the code start point and end point where it is taking 99% of time to do this task.

Sub UpdateAttachmentColumn_RequestManager()

    Dim rng As Range, rngeach As Range, rngData As Range
    Dim RequestID As String
    Dim iLastRow As Integer
    Dim wsTarget As Worksheet
    Dim dicAttachmentData As Scripting.Dictionary

    Set wsTarget = Sheet17
    'Updating the Attachment Hyperlink Data In The Dictionary
    Set dicAttachmentData = Application.Run(Macro:="FetchHyperlinkData")
    iLastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
    Set rngData = wsTarget.Range(wsTarget.Cells(3, 17), wsTarget.Cells(iLastRow, 17))
    On Error Resume Next
    Set rng = rngData.SpecialCells(xlCellTypeConstants, 23)
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    'updating "Attachment" Column In The Sheet "Request Manager"
[B]    'Start This Part is taking 99% time[/B]
    If Not rng Is Nothing Then
        For Each rngeach In rng
            RequestID = wsTarget.Cells(rngeach.Row, "A").Value
            wsTarget.Hyperlinks.Add Anchor:=rngeach, _
                                Address:="D:\Workflow Tools\Attachments\" & _
                                Trim(dicAttachmentData.Item(RequestID)(0)) & "\" & _
                                Trim(dicAttachmentData.Item(RequestID)(1)) & "\" & _
                                Trim(MonthName(dicAttachmentData.Item(RequestID)(2))) & "\" & _
                                Trim(RequestID), _
        Next rngeach
    End If
[B]    'End This Part is taking 99% time[/B]
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    Sheet19.Visible = xlSheetVeryHidden
End Sub

Private Function FetchHyperlinkData() As Scripting.Dictionary
    Dim CovArray As Variant, varTemp As Variant
    Dim strSQL As String
    Dim iLastRow As Integer, iValue As Integer
    Dim lLoop As Long
    Dim dicAttachmentData As Dictionary
    On Error Resume Next
    Application.ScreenUpdating = False
    Sheet19.Visible = xlSheetVisible
    iValue = Range("AttachmentsCol_Query").Column
    iLastRow = Sheet19.Cells(Rows.Count, iValue).End(xlUp).Row
    For iLoop = 2 To iLastRow
        strSQL = strSQL & Sheet19.Cells(iLoop, iValue).Value & vbCrLf
    Next iLoop
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    cn.Provider = "sqloledb"
    cn.Open = "Server=DTC01;Initial Catalog=DataP;Integrated Security=SSPI;"
    Set rs.ActiveConnection = cn
    rs.Open strSQL, cn, 1, 3

    CovArray = rs.GetRows

    CovArray = transposeArray(CovArray)

    Set dicAttachmentData = New Scripting.Dictionary
    dicAttachmentData.CompareMode = TextCompare
    'Start Filling Recordset Data In Dictionary
    For lLoop = UBound(CovArray, 1) To LBound(CovArray, 1) Step -1
        If Not dicAttachmentData.Exists(CovArray(lLoop, 0)) Then
            dicAttachmentData.Add Key:=CovArray(lLoop, 0), Item:=Array(CovArray(lLoop, 1), _
                                                            CovArray(lLoop, 2), _
                                                            CovArray(lLoop, 3))
            varTemp = dicAttachmentData.Item(CovArray(lLoop, 0))
            varTemp(0) = CovArray(lLoop, 1)
            varTemp(1) = CovArray(lLoop, 2)
            varTemp(2) = CovArray(lLoop, 3)
            dicAttachmentData.Item(CovArray(lLoop, 0)) = varTemp
        End If
    Next lLoop
    'End Filling Recordset Data In Dictionary
    Set FetchHyperlinkData = dicAttachmentData

End Function

Function transposeArray(myarr As Variant) As Variant
    Dim myvar As Variant
    ReDim myvar(LBound(myarr, 2) To UBound(myarr, 2), LBound(myarr, 1) To UBound(myarr, 1))
    For i = LBound(myarr, 2) To UBound(myarr, 2)
        For j = LBound(myarr, 1) To UBound(myarr, 1)
            myvar(i, j) = myarr(j, i)
    transposeArray = myvar
End Function

Please help me, where I need to change in the code so that it could work more fast.

Last edited:

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

Forum statistics

Latest member

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