Efficient method to add hyperlink

[sharky12345]

Afternoon guys,

I'm trying to find an efficient method to add a hyperlink to a range of cells but what I have so far keeps generating an 'Out of memory' message. The code itself runs fine, but once it's complete I get the message. This is what I have so far:

LastImportRow = Sheet7.Range("A65000").End(xlUp).Row

For Each Cell In Sheet7.Range("D2:D" & LastImportRow)


On Error Resume Next
If Cell = 1 Then


LastRow = Sheet3.Range("A65000").End(xlUp).Row + 1
Sheet3.Range("B" & LastRow) = Cell.Offset(0, -2)
Sheet3.Range("G" & LastRow) = Cell.Offset(0, -3)


Path = "ds://" & Sheet3.Range("G" & LastRow).Value
ScreenTip = "Direct link"
TextToDisplay = Sheet3.Range("B" & LastRow)


Sheet3.Range("H" & LastRow).Select
Sheet3.Range("H" & LastRow).Hyperlinks.Add Anchor:=Selection, Address:=Path, ScreenTip:=ScreenTip, TextToDisplay:=TextToDisplay


End If
Next

I may be probably completely wrong, but is the issue that it's having to select each cell to add the hyperlink?

Is there a more efficient method to do this?

 

[Yongle]

( untested )
Try this in a COPY of your workbook

    Dim LastImportRow  As Long, LastRow As Long, Cell As Range, linkCell As Range, Path As String, TxtToDisplay As String
    Const ScreenTip = "Direct link"
    LastImportRow = Sheet7.Range("A65000").End(xlUp).Row
    Application.ScreenUpdating = False
    For Each Cell In Sheet7.Range("D2:D" & LastImportRow)
        On Error Resume Next
        If Cell = 1 Then
            LastRow = Sheet3.Range("A65000").End(xlUp).Row + 1
            Sheet3.Range("B" & LastRow) = Cell.Offset(0, -2)
            Sheet3.Range("G" & LastRow) = Cell.Offset(0, -3)
            Path = "ds://" & Sheet3.Range("G" & LastRow).Value
            TxtToDisplay = Sheet3.Range("B" & LastRow)
            Set linkCell = Sheet3.Range("H" & LastRow)
            linkCell.Hyperlinks.Add Anchor:=linkCell, Address:=Path, ScreenTip:=ScreenTip, TextToDisplay:=TxtToDisplay
        End If
        On Error GoTo 0
    Next Cell

Range("A65000").End(xlUp).Row Which version of Excel are you using ?

 

[sharky12345]

Thanks - I'll give that a try!