Option Explicit
Const StartData As String = "D3"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Select Case Sh.Name
Case "Lists"
If Application.Intersect(Columns(Target.column), _
Sh.Range(StartData).CurrentRegion) _
Is Nothing Then Exit Sub
FishMyShape Target
End Select
End Sub
Private Sub FishMyShape(myCell As Range)
Const myShpType As Long = 5
Dim strgShapeID As String
strgShapeID = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
On Error GoTo errorhandler
With Sheets("Checklist Structure").Shapes(strgShapeID)
If Len(Trim(myCell.Text)) > 0 Then
.TextFrame2.TextRange.Characters.Text = myCell.Text
Else
.Delete
End If
End With
Exit Sub
errorhandler:
AddShape myCell
End Sub
Sub AddShape(myCell As Range)
Dim shp As Excel.Shape
Dim myT, myL As Single
Const myShpType As Long = 5
Const W As Single = 160.5
Const H As Single = 19.5
Const T As Single = 276.4688
Const L As Single = 211.5
Const Gap As Single = 29.2243
myT = CSng(T + (Gap * (myCell.row - Range(StartData).row)))
myL = CSng(L * (1 + (myCell.column - Range(StartData).column)))
Set shp = Worksheets("Checklist Structure").Shapes.AddShape(myShpType, myL, myT, W, H)
With shp
.TextFrame2.TextRange.Characters.Text = myCell.Value
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.OnAction = "'" & ThisWorkbook.Name & "'!RoundedRectangleSubcategory_Click"
.Name = Format(myShpType, "000") & Replace(myCell.Address, "$", "")
End With
End Sub