Excel VBA Taking Long Time To Update Hyperlink On Each Cell

[kashif.special2005]

Hi,

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
            rngeach.ClearContents
            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), _
                                TextToDisplay:="*"
        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))
        Else
            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)
        Next
    Next
    transposeArray = myvar
End Function

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

Thanks
Kashif