Efficient method to add hyperlink

sharky12345

Well-known Member
Joined
Aug 5, 2010
Messages
3,283
Office Version
2016
Platform
Windows
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:

Code:
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

Well-known Member
Joined
Mar 11, 2015
Messages
4,984
Office Version
365
Platform
Windows
( untested )
Try this in a COPY of your workbook

Code:
    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

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

Forum statistics

Threads
1,086,227
Messages
5,388,571
Members
402,125
Latest member
mtwood83

Some videos you may like

This Week's Hot Topics

Top