Option Explicit
Const myShpType As Long = 5
Const myShpWidt As Single = 160.5
Const myShpHgth As Single = 19.5
Const fstShpTop As Single = 276.4688
Const fstShpLft As Single = 211.5
Const fstShpGap As Single = 29.2243
Const StartData As String = "D3"
Dim wshData As Worksheet
Dim wshSpap As Worksheet
Dim IsExist As Boolean
Sub HoldMyShapes()
Dim rngData As Range, c As Range
Set wshData = ActiveWorkbook.Sheets("Lists")
Set wshSpap = ActiveWorkbook.Sheets("Checklist Structure")
Set rngData = wshData.Range(StartData).CurrentRegion
For Each c In rngData
If c.Font.Bold Then
ElseIf c.Font.Italic Then
Else
IsExist = False
If Len(Trim(c.Value)) > 0 Then
FishMyShape c
If Not IsExist Then MakeShape c
End If
End If
Next c
End Sub
Private Sub MakeShape(myCell As Range)
Dim myTop As Single
Dim myLft As Single
Dim oShp As Object
myTop = CSng(fstShpTop + fstShpGap * (myCell.row - Range(StartData).row))
myLft = fstShpLft * (1 + (myCell.column - Range(StartData).column))
Set oShp = wshSpap.Shapes.AddShape(myShpType, myLft, myTop, myShpWidt, myShpHgth)
With oShp
.TextFrame2.TextRange.Characters.Text = myCell.Text
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(112, 48, 160)
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.OnAction = "'" & ThisWorkbook.Name & "'!RoundedRectangleSubcategory_Click"
.Name = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
End With
End Sub
Private Sub FishMyShape(myCell As Range)
Dim Test
Dim strgShapeID As String
strgShapeID = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
On Error GoTo errorhandler
Test = wshSpap.Shapes(strgShapeID).Top
IsExist = True
Exit Sub
errorhandler:
CareMyShape myCell.Text, strgShapeID
End Sub
Private Sub CareMyShape(myText As String, myID As String)
Dim oShp As Shape
For Each oShp In wshSpap.Shapes
If oShp.AutoShapeType = myShpType Then
If oShp.TextFrame2.TextRange.Characters.Text = myText Then
oShp.Name = myID
IsExist = True
Exit Sub
End If
End If
Next oShp
End Sub