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

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

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

Answer 2

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