如何将同一单元格上的每一行文本转换为超链接，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

This link for the Sheet https://easyupload.io/wqmpkg

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

As told by others, in one cell you can have only one hyperlink.

Note : You have in some cells the same attachment name duplicated!

I quote what you said "is it possible to split cells with multi lines to adjacent cells and converts to hyperlinks afterwards", so this code might do what you need.

Sub Convert_To_Hyperlinks()
    Dim rng As Range
    Dim WorkRng As Range
    Dim LastRow As Long
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    Dim i As Integer
    Dim lastCol As Long
    Dim arrStr() As String
     
    Set WorkRng = ws.Range("N2", ws.Cells(Rows.Count, "N").End(xlUp))
    
    For Each rng In WorkRng
        ' find last column for current row
        lastCol = ws.Cells(rng.Row, Columns.Count).End(xlToLeft).Column
        
        If InStr(1, rng.Value, Chr(10)) > 0 Then
            ' multiple attachments: split text into array
            arrStr = Split(rng.Value, Chr(10))
            
            ' copy array after last column
            Cells(rng.Row, lastCol + 1).Resize(1, UBound(arrStr) - LBound(arrStr) + 1) = arrStr
            
            ' create hyperlink
            For i = LBound(arrStr) To UBound(arrStr)
                Application.ActiveSheet.Hyperlinks.Add Cells(rng.Row, lastCol + 1 + i), arrStr(i)
            Next i
        
        ElseIf rng.Value <> "" Then
            ' only one attachment: copy range value after last column
            Cells(rng.Row, lastCol + 1).Value = rng.Value
            
            ' create hyperlink
            Application.ActiveSheet.Hyperlinks.Add Cells(rng.Row, lastCol + 1), rng.Value
        End If
    Next rng
End Sub

Answer 2

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