excel - 如何在单元格中插入/创建符号并根据给定标准超链接每个符号？

Question

我已经尝试搜索几天的解决方案或想法如何在 Excel VBA 中执行此操作，但是我找不到满足我需求的类似方案。

这个想法是这样的:

我有下表作为超链接的引用:

现在，在单独的列上，我想在引用编号的每个相应的下一列中创建一个“+”形状，并使每个形状成为引用所提供的第一张图像的超链接。它可以在一个单元格中包含一个或多个形状，直到完成该引用编号的所有链接。

我想在 VBA 中执行此操作，因为在 Excel 中不可能在单个单元格中存在多个链接，因此形状/图像/符号超链接是我能想到的唯一解决方案。我不知道从哪里开始或如何开始。

我希望有人能够指导我，因为我仍在学习 Excel VBA。预先感谢您。

Answer 1

设置引用 Microsoft Scripting Runtime

Sub SetHyperlinkOnShape()
    ' reference Microsoft Scripting Runtime
        Dim ws As Worksheet, ws2 As Worksheet, dict As dictionary
        Dim tKey(0) As Variant
        Dim LRandomNumber As Integer
        Set ws = ThisWorkbook.Sheets("Sheet1")
        Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Application.ScreenUpdating = False
    DeleteAllShapes ws2
        Dim hyperLinkedShape As Shape
        Dim t As Range
        ColumnToPasteNumber = 2 ' on Sheet2 Column B
        ColumnAlpha = "A" ' Column Latter from SHeet1 in your case H
        LastRow = ws.Cells(ws.Rows.Count, ColumnAlpha).End(xlUp).Row ' get last row
        Set dict = CreateObject("Scripting.Dictionary") ' put all unique value to dictionary
        Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 2))
        For ci = 1 To LastRow ' change 1 to 2 in your case to start from second row as you have headers
            strName = Rng(ci, 1)
            strLink = Rng(ci, 2)
            If dict.Exists(strName) Then
                Dim tempArr() As Variant
                tempArr() = dict(strName)
                    sCount = UBound(tempArr) + 1
                    ReDim Preserve tempArr(0 To sCount)
                    tempArr(sCount) = strLink
                dict(strName) = tempArr
            Else
                tKey(0) = strLink
                dict.Add strName, tKey
            End If
        Next ci
            For Each UniqueVal In dict ' loop dictionary to paste to cells
                i = i + 1
                Set t = ws2.Range(ws2.Cells(i, ColumnToPasteNumber), ws2.Cells(i, ColumnToPasteNumber))
                    NumbersOfPluses = UBound(dict(UniqueVal)) + 1
                    sw = t.Width / NumbersOfPluses
                    ws2.Cells(i, 1).Value = UniqueVal
                    For y = 1 To NumbersOfPluses ' set default shape width sw
                        sw = t.Height 'in points
                        sL = t.Left + sw * (y - 1)
                        If y = 1 Then sL = t.Left
                        Set hyperLinkedShape = ws2.Shapes.AddShape(msoShapeMathPlus, sL, t.Top, sw, t.Height)
                            hyperLinkedShape.Placement = xlFreeFloating ' do not size and dont move
                                strLink = dict(UniqueVal)(y - 1)
                                strHint = "Click ME"
                            ws2.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:=strLink, SubAddress:="", ScreenTip:=strHint
                    Next y
                    If getMaxCellWidth < t.Height * NumbersOfPluses Then getMaxCellWidth = t.Height * NumbersOfPluses
            Next UniqueVal
            ' ColumnWidth in units !!!
        ws2.Columns("B:B").ColumnWidth = (((getMaxCellWidth) / 0.75 - 5) / 7) ' convert points to units
    Application.ScreenUpdating = True

End Sub

            Sub DeleteAllShapes(ws As Worksheet)
                Dim shp As Shape

                For Each shp In ws.Shapes
                   shp.Delete
                Next shp
            End Sub