How to convert each line of text on the same cell to hyperlinks , Excel vba?

Question

How to convert each line of text on the same cell to hyperlinks ?

the below code works correctly if cells has only one line of text !

Note: any workarounds is accepted.

Sub Convert_To_Hyperlinks()

  Dim Rng As Range
  Dim WorkRng As Range
  Dim LastRow As Long
  Dim ws As Worksheet
   
  Set ws = ActiveSheet
    
  Set WorkRng = ws.Range("N2", ws.Cells(Rows.Count, "N").End(xlUp))

  For Each Rng In WorkRng
  Application.ActiveSheet.Hyperlinks.Add Rng, Rng.Value
  Next Rng
  
End Sub

Answer 1

Excel allows only one hyperlink per cell. So, in order to do what you need, a workaround should be necessary. I would propose adding text boxes over each cell, placing the hyperlink text in them and add hyperlink to each text box.

Please, test the next code:

Sub testHyperlinkUsingShapes()
   Dim sh As Worksheet, s As Shape, arrH, cHyp As Range, sHeight As Double
   Dim rngHyp As Range, sWidth As Double, relTop As Double, i As Long
   
    Set sh = ActiveSheet
    Set rngHyp = sh.Range("N2:N" & sh.Range("N" & sh.Rows.Count).End(xlUp).Row)

    'a little optimization to make the code faster:
    Application.EnableEvents = False: Application.ScreenUpdating = False
    deleteTextBoxes 'for the case when you need repeating the process (if manually changed some cells hyperling strings)
    For Each cHyp In rngHyp.Cells 'iterate between cells of the range to be processed
        If cHyp.Value <> "" Then  'process only not empty cells
            arrH = filterSimilarH(cHyp) '1D array 1 based af unique hyperlink strings...
            sHeight = cHyp.Height / UBound(arrH) 'set the height of the text boxes to be created
            sWidth = cHyp.Width 'the same for the with
            For i = 1 To UBound(arrH) 'for each found (unique) hyperlink strings:
                'create a text box with dimensions set above
                Set s = sh.Shapes.AddTextbox(msoTextOrientationHorizontal, cHyp.Left, cHyp.Top + relTop, sWidth, sHeight)
                sh.Hyperlinks.Add Anchor:=s, Address:=arrH(i) 'add hyperlink address
                With s
                    .TextFrame2.TextRange.Text = arrH(i) 'place the hyperlink string as the text box text
                    .TextFrame2.TextRange.Font.Size = cHyp.Font.Size 'match the font size with the cell one
                    .TextFrame2.TextRange.Font.Name = cHyp.Font.Name 'match the font type with the cell one
                    .TextFrame2.VerticalAnchor = msoAnchorMiddle 'center the text
                    .Line.ForeColor.ObjectThemeColor = msoThemeColorText1 'match the border line coloor with the cell one
                    .Placement = xlMoveAndSize
                End With
                s.Hyperlink.Address = arrH(i) 'set the hyperlink address
                relTop = relTop + sHeight 'adapt the Top position for the next text box to be places in the same cell
            Next i
            relTop = 0 'reinitialize the top for the next cell
        End If
    Next
    Application.EnableEvents = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub

Sub deleteTextBoxes() 'delete the existing text boxes, if any
   Dim s As Shape
   For Each s In ActiveSheet.Shapes
        If s.Type = msoTextBox Then
            If s.TopLeftCell.Column = 14 Then
                s.Delete
            End If
        End If
   Next
End Sub

Function filterSimilarH(rngCel As Range) As Variant
  Dim arr, uniques: arr = Split(rngCel.Value, vbLf) 'keep only unique hyperlinks, if duplicates exist
  
  With Application
      uniques = .Index(arr, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & _
                  UBound(.Match(arr, arr, 0)) & ")")), .Match(arr, arr, 0), 0), "|"), "|", False))
  End With
   filterSimilarH = uniques
End Function