Как вставить / создать символ в ячейке и гиперссылку каждого символа в соответствии с заданными критериями?

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