Copy cell with hyperlink to multiple sheets with same cell value

Question

Doing a VBA for excel macro to Copy the Cell with Hyperlink(hyperlink to sheets in the workbook) to multiple cells with same active cell value in the workbook.

Tried this so far, could not copy the hyperlink with this.

Sub FindReplacewithHyperlink()

Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim oRng As Range

fnd = ActiveCell.Value
rplc = ActiveCell.Value

For Each sht In ActiveWorkbook.Worksheets

   sht.Cells.Replace what:=fnd, Replacement:=rplc, _
   LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
   SearchFormat:=False, ReplaceFormat:=False

Next sht

End Sub

Answer 1

Welcome! Your solution is actually pretty close but Find/Replace unfortunately does not copy hyperlinks. This method copies the hyperlink from the selected cell, uses the UsedRange of each sheet to find cells with the same value, and adds the hyperlink to each cell individually.

Sub FindReplacewithHyperlink()
Dim sht As Worksheet
Dim fnd As Range, cell As Range
Dim h As Variant
Dim hl As Hyperlink

'define active cell
Set fnd = ActiveCell

'grab the in-workbook hyperlink from active cell
h = fnd.Hyperlinks(1).SubAddress

'loop through all sheets
For Each sht In ActiveWorkbook.Worksheets
    
    'loop through all used cells on sheet
    For Each cell In sht.UsedRange
        
        'if value of cell = value of active cell
        If cell.Value = fnd.Value Then
            
            'remove any existing hyperlink
            For Each hl In cell.Hyperlinks
                hl.Delete
            Next hl
            
            'add new hyperlink
            sht.Hyperlinks.Add cell, "", h
            
        End If
        
    Next cell
    
Next sht

End Sub

If you have any questions feel free to let us know!

Answer 2

Since Excel contains very complex number type with the script i was getting runtime error 13 (type mismatch). So I did a small update in the "if section" to have string instead integer/value. Its working now

Sub FindReplacewithHyperlink()
Dim sht As Worksheet
Dim fnd As Range, cell As Range
Dim h As Variant
Dim hl As Hyperlink

'define active cell
Set fnd = ActiveCell

'grab the in-workbook hyperlink from active cell
h = fnd.Hyperlinks(1).SubAddress

'loop through all sheets
For Each sht In ActiveWorkbook.Worksheets

'loop through all used cells on sheet
For Each cell In sht.UsedRange
    
    'if value of cell = value of active cell
    If CStr(cell.Value) = CStr(fnd.Value) Then
        
        'remove any existing hyperlink
        For Each hl In cell.Hyperlinks
            hl.Delete
        Next hl
        
        'add new hyperlink
        sht.Hyperlinks.Add cell, "", h
        
    End If
    
Next cell

Next sht

End Sub