Compare each cell entry with shape text

[VBAnoob_Corina]

Hello everybody,

hope you can help me with the following problem: I'm trying to compare some cell entries from a worksheet to some shape text on another sheet. I have written some code already, but I get nothing but errors no matter what I try. The cell entries are located in "Lists", in the columns D-G and each amount of entries may vary. My shapes are plain rounded rectangles located in "Checklist Structure". I need this comparison as a condition for some further code which generates and places new shapes for entries not matching any shape text. I hope you can somehow understand what I'm trying to achieve I'm also very grateful for any help I can get. Thank you very much for the support!

Kind regards,
VBAnoob_Corina (The name says it all )

Option Explicit
Sub CreateShapes()

Dim ws As Worksheet
Dim SrchRng
Dim shp As Excel.Shape
Dim myText As Variant
Dim c As Range
Dim cellEntry As Variant
Dim lastRow

On Error GoTo ErrHandler

Set ws = Worksheets("Lists")
Set shp = Worksheets("Checklist Structure").Shapes(1)
lastRow = ws.Cells(Rows.count, 1).End(xlUp).row
Set SrchRng = ws.Range("D3:P" & lastRow)
myText = shp.TextFrame2.TextRange.Characters.Text
cellEntry = SrchRng.Cells.Value

With ws
    For Each cellEntry In SrchRng
        If cellEntry <> "" Then 'If cell is not blank then compare entry with each shape text
        Set c = SrchRng.Find(cellEntry, LookIn:=myText)
             If Not c Is Nothing Then 'do nothing
             Else
             MsgBox ("Bisher klappts!")
             End If
        Else 'do nothing
        End If
    Next cellEntry
End With

ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Error " & Err.number)


End Sub

 

[Andrew Poulsom]

Maybe this will help you:

Sub Test()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim SrchRng As Range
    Dim c 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
    Set ws = Worksheets("Lists")
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set SrchRng = ws.Range("D3:P" & lastRow)
    For Each c In SrchRng.Cells
        Found = False
        For Each shp In Worksheets("Checklist Structure").Shapes
            myText = shp.TextFrame2.TextRange.Characters.Text
            If c.Value = myText Then
                Found = True
                Exit For
            End If
        Next shp
        If Found = False Then
            Count = Count + 1
            ReDim Preserve AllCells(1 To Count)
            AllCells(Count) = c.Value
        End If
    Next c
    For i = LBound(AllCells) To UBound(AllCells)
'       Insert code to create missing shapes
        MsgBox "Shape with text " & AllCells(i) & " is missing."
    Next i
End Sub

 

[VBAnoob_Corina]

Hello Andrew,

thank you so very much for code you posted. It seems to be exactly what I was looking for. But I have to admit that I don't understand the last part. Could you please explain what the following rows do?

        If Found = False Then
            Count = Count + 1
            ReDim Preserve AllCells(1 To Count)
            AllCells(Count) = c.Value
        End If
    Next c
    For i = LBound(AllCells) To UBound(AllCells)
'       Insert code to create missing shapes
        MsgBox "Shape with text " & AllCells(i) & " is missing."
    Next i
End Sub

I was also wondering whether it is possible to add the shape right after the code discovered that a cell entry can't be found in any of the shapes... My idea was to create directly a shape with the relevant text. Or does anything speak against this approach?

Again, thank you very much for the help. You saved the day and most probably even the whole week

Best regards
Corina

 

[Andrew Poulsom]

The code just creates an array of the missing text and loops around it. I left you to add the shapes because I don't know their type or location. You can add the shapes in the If Found = False part and avoid the loop around the array.

 

[VBAnoob_Corina]

Hello Andrew,

sorry for my late response. I wasn't able to test the code properly until now. It's working perfectly fine, but not doing what I originally intended... Somehow I get incorrect results, meaning that cell text which is obviously used as a shape content was declared as missing. Also cell text which isn't in any of the shapes couldn't be identified... I'm confused...

Maybe I made a mistake when I adjusted the code a little bit to fit my new range and skip the blank cells...

Sub Test()
Dim ws As Worksheet
Dim lastRow As Long
Dim SrchRng As Range
Dim c 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")
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).row
Set SrchRng = ws.Range("D2:G" & lastRow)
For Each c In SrchRng.Cells
    Found = False
    If c <> "" Then
        For Each shp In Worksheets("Checklist Structure").Shapes
            If shp.Type = msoShapeRoundedRectangle Then
                myText = shp.TextFrame2.TextRange.Characters.Text
                If c.Value = myText Then
                Found = True
                Exit For
                End If
            End If
        Next shp

        If Found = False Then
        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)
'       Insert code to create missing shapes
MsgBox "Shape with text " & AllCells(i) & " is missing."
Next i

Exit Sub
  
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.number)

End Sub

Have you got any idea what might have went wrong? Interestingly, the entries in D2, E2, F2 and G2 are supposed to be missing but are actually there. Furthermore, the entries which actually are missing (located in D10, E13, F8, G13, also representing the last used cell in the column) could not be found. I can imagine that my search range isn't correct. But experimenting around didn't really help...

Thank you very much.

Kind regards
Corina

 

[Andrew Poulsom]

Do you want to put your workbook on a share like Box.Net so that I can take a look? Post the URL in a reply.

 

[Andrew Poulsom]

Having looked at your workbook:

1.You can't use column A for lastRow because it's empty.
2. You don't have any Shapes with Type msoShapeRoundedRectangle. The Types are msoAutoShape (1) and msoFormControl (8). Maybe you need to use AutoShapeType.

 

[VBAnoob_Corina]

Having looked at your workbook:

1.You can't use column A for lastRow because it's empty.
2. You don't have any Shapes with Type msoShapeRoundedRectangle. The Types are msoAutoShape (1) and msoFormControl (8). Maybe you need to use AutoShapeType.

Hello Andrew,

I applied the changes you suggested but now I get an error message for the part "myText = shp.TextFrame2.TextRange.Text" saying that the specified value is out of range (Error 440). I don't get it, I only changed the parameters for the last row and the shape type... What is the cause of this error and how can I correct it?

Sub Test()
Dim ws As Worksheet
Dim lastRow As Long
Dim SrchRng As Range
Dim c As Range
Dim Found As Boolean
Dim shp As Shape
Dim myText As Range
Dim Count As Long
Dim AllCells() As Variant
Dim i As Long

On Error GoTo ErrHandler

Set ws = Worksheets("Lists")
lastRow = ws.Cells(Rows.Count, 7).End(xlUp).row
Set SrchRng = ws.Range("D2:G" & lastRow)

For Each c In SrchRng.Cells
    Found = False
    If c <> "" Then
        For Each shp In Worksheets("Checklist Structure").Shapes
            If shp.Type = 1 Then
            myText = shp.TextFrame2.TextRange.Characters.Text
                    If c.Value = myText Then
                    Found = True
                    Exit For
                    End If
            End If
        Next shp

        If Found = False Then
        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

 

[Andrew Poulsom]

Try:

Sub Test()
    Dim ws As Worksheet
    Dim SrchRng As Range
    Dim c 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 SrchRng = ws.Range("D2").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
                        Exit For
                    End If
                End If
            Next shp
            If Found = False Then
                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

 

[VBAnoob_Corina]

Hello Andrew,

thank you very much for your response as well as the posted code. The last one does exactly what it is supposed to do and
provides the correct results

Kind regards,
Corina