excel - 如何将同一单元格上的每一行文本转换为超链接，Excel vba？

Question

如何将同一单元格上的每一行文本转换为超链接？
如果单元格只有一行文本，则以下代码可以正常工作!
备注 :接受任何变通方法
工作表的此链接 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 每个单元格只允许一个超链接。所以，为了做你需要的事情，一个变通方法应该是必要的。我建议在每个单元格上添加文本框，将超链接文本放置在其中，并将超链接添加到每个文本框。
请测试下一个代码:

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)
    
    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
        If cHyp.Value <> "" Then
            arrH = filterSimilarH(cHyp) '1D array 1 based...
            sHeight = cHyp.Height / UBound(arrH)
            sWidth = cHyp.Width
            For i = 1 To UBound(arrH)
                Set s = sh.Shapes.AddTextbox(msoTextOrientationHorizontal, cHyp.Left, cHyp.Top + relTop, sWidth, sHeight)
                sh.Hyperlinks.Add Anchor:=s, Address:=arrH(i)
                With s
                    .TextFrame2.TextRange.Text = arrH(i)
                    .TextFrame2.TextRange.Font.Size = cHyp.Font.Size
                    .TextFrame2.TextRange.Font.Name = cHyp.Font.Name
                    .TextFrame2.VerticalAnchor = msoAnchorMiddle
                    .Line.ForeColor.ObjectThemeColor = msoThemeColorText1
                    .Placement = xlMoveAndSize
                End With
                s.Hyperlink.Address = arrH(i)
                relTop = relTop + sHeight
            Next i
            relTop = 0
        End If
    Next
    Application.EnableEvents = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub

Sub deleteTextBoxes()
   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)
  
  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