Private c As Range
Const StartData As String = "D3"
Option Explicit
Private Sub CompListWthShpText()
Dim ws As Worksheet, wsCS As Worksheet
Dim SrchRng As Range
Dim Found As Boolean
Dim shp As Excel.Shape
Dim myText As Variant
Dim count As Long
Dim AllCells() As Variant
Dim i As Long
On Error GoTo ErrHandler
Set ws = Worksheets("Lists")
Set wsCS = Worksheets("Checklist Structure")
Set SrchRng = ws.Range("D3").CurrentRegion
For Each c In SrchRng.Cells
Found = False
If c <> "" Then
For Each shp In Worksheets("Checklist Structure").Shapes
If shp.AutoShapeType = msoShapeRoundedRectangle Then
myText = shp.TextFrame2.TextRange.Characters.Text
If c.Value = myText Then
Found = True
c.Interior.ColorIndex = 4
Exit For
End If
End If
Next shp
If Found = False Then
Call AddShape
count = count + 1
ReDim Preserve AllCells(1 To count)
AllCells(count) = c.Value
End If
End If
Next c
For i = LBound(AllCells) To UBound(AllCells)
MsgBox "Shape with text " & AllCells(i) & " is missing."
Next i
Exit Sub
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.number)
End Sub
Private Sub AddShape()
Dim Found As Boolean
Dim SrchRng 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
Set SrchRng = Worksheets("Lists").Range(StartData).CurrentRegion
myT = CSng(T + (Gap * (c.row - Range(StartData).row)))
myL = L * (1 + (c.column - Range(StartData).column))
Set shp = Worksheets("Checklist Structure").Shapes.AddShape(myShpType, myL, myT, W, H)
With shp
.TextFrame2.TextRange.Characters.Text = c.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"
End With
End Sub