How do I save the fidelity of this hyperlink using VBA?

[born2dive00]

Hello all

So I was able to create a formula that looked at cells Sheet2 A8 and B8 to create a hyperlink in C8, using this formula. =IF(OR(A8,(B8)=" "),(""),HYPERLINK(B8,A8))
This does exactly what I want it to do by creating a hyperlink, simple enough.

Now using this VBA Code I was able to put the result C8 (my newly created hyperlink) into Sheet1 A1, all good so far, I got the text without a code in A1 (it is imperative that A1 is free from typed formulas, as it will go into a table, and the formula will cause a mismatch).

HOWEVER it put the value in A1 as a text, and lost the newly generated hyperlink.

How can I preserve the fidelity of the generated Hyperlink (NOT the code, only the hyperlink!) with the VBA code???

Book attached

Thank you all for your help

[Andy Pope]

If you are not using the formula then you will need to add a hyperlink. The tough part is extracting the information from the formula

Sub Diver()

    Dim s1 As Worksheet, s2 As Worksheet
    Dim linkAddress As String
    Dim linkText As String
    Dim pos As Long
    Dim formulaText As String
    Dim linkRange As Range
    
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    s1.Range("A1") = s2.Range("C8")
    
    ' get formula from C8
    formulaText = s2.Range("C8").Formula
    pos = InStr(1, formulaText, "HYPERLINK(", vbTextCompare)
    If pos > 0 Then
        ' formula contains HYPERLINK function so extract the two arguments
        linkAddress = Split(Mid(formulaText, pos + 10), ",")(0)
        ' check is the argument is a range reference
        On Error Resume Next
        Set linkRange = Range(linkAddress)
        On Error GoTo 0
        If Not linkRange Is Nothing Then
            linkAddress = linkRange.Value
        End If
        
        linkText = Split(Split(Mid(formulaText, pos + 10), ",")(1), ")")(0)
        ' check is the argument is a range reference
        On Error Resume Next
        Set linkRange = Range(linkText)
        On Error GoTo 0
        If Not linkRange Is Nothing Then
            linkText = linkRange.Value
        End If
        
        ' add hyperlink to A1
        s1.Range("A1").Hyperlinks.Add s1.Range("A1"), linkAddress, "", linkText, linkText
    End If

End Sub

[born2dive00]

Hey Andy that worked great!

I have 3 more steps that I need help with Can you show me the code to expand to more cells, So I can see the changes in the code.
I have attached the same book with more examples and a table

[Andy Pope]

This will start in C8 and A1 and process until it encounters an empty cell

Sub Diver()

    Dim s1 As Worksheet, s2 As Worksheet
    Dim inputCell As Range
    Dim outputCell As Range
    
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    
    Set inputCell = s2.Range("C8")
    Set outputCell = s1.Range("A1")
    Do While Len(inputCell.Value) > 0
        outputCell.Value = inputCell.Value
        m_ConvertFormulaToHyperlink inputCell, outputCell
        Set inputCell = inputCell.Offset(1, 0)
        Set outputCell = outputCell.Offset(1, 0)
    Loop
    
End Sub
Private Sub m_ConvertFormulaToHyperlink(InCell As Range, OutCell As Range)

    Dim linkAddress As String
    Dim linkText As String
    Dim pos As Long
    Dim formulaText As String
    Dim linkRange As Range
    
    formulaText = InCell.Formula
    pos = InStr(1, formulaText, "HYPERLINK(", vbTextCompare)
    If pos > 0 Then
        ' formula contains HYPERLINK function so extract the two arguments
        linkAddress = Split(Mid(formulaText, pos + 10), ",")(0)
        ' check is the argument is a range reference
        On Error Resume Next
        Set linkRange = Range(linkAddress)
        On Error GoTo 0
        If Not linkRange Is Nothing Then
            linkAddress = linkRange.Value
        End If
        
        linkText = Split(Split(Mid(formulaText, pos + 10), ",")(1), ")")(0)
        ' check is the argument is a range reference
        On Error Resume Next
        Set linkRange = Range(linkText)
        On Error GoTo 0
        If Not linkRange Is Nothing Then
            linkText = linkRange.Value
        End If
        
        ' add hyperlink to A1
        OutCell.Hyperlinks.Add OutCell, linkAddress, "", linkText, linkText
    End If


End Sub