How to insert/create symbol in the cell and hyperlink each symbol according to given criteria? - excel

Question

I've been trying to search for days already for solutions or idea how to do this in Excel VBA, however I cannot find a similar scenario for my needs.
Here's the idea:
I have the following table as reference for the hyperlinks:
Now on a separate column, I want to create a "+" shape in each corresponding next column of the reference number and make each shape a hyperlink in reference to the first image provided. It may contain one or more shapes in one cell until all the links for that reference number has been made.
I want to do this in VBA because multiple links in single cell is not possible in Excel and hence shape/image/symbol hyperlinking is the only solution I can think of. I am clueless where to start or how to start.
I hope someone will be able to direct me as I am still learning on Excel VBA. Thank you in advance.

Answer 1

Set reference 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