AboutPricingCommunityTeamsStart Free TrialLog in
Avatar of Trygve Thayer
Trygve Thayer
Flag for United States of America asked on

VB Code to test if Shape contains text.

I have a macro that copies shapes from one sheet to another sheet.  What I would like to do is test if the shape has text.  If so copy it.  If not do not.  Below is the code.  If there is a cleaner way to do this I am all ears.

Sub Stop_1_53()

    ActiveSheet.Shapes("TextBox 111").Copy
    Application.Goto Sheets("53").Range("FI28")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 112").Copy
    Application.Goto Sheets("53").Range("FI29")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 113").Copy
    Application.Goto Sheets("53").Range("FI30")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 114").Copy
    Application.Goto Sheets("53").Range("FI31")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 115").Copy
    Application.Goto Sheets("53").Range("FI32")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 116").Copy
    Application.Goto Sheets("53").Range("FI33")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 117").Copy
    Application.Goto Sheets("53").Range("FI34")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 118").Copy
    Application.Goto Sheets("53").Range("FI35")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 119").Copy
    Application.Goto Sheets("53").Range("FI36")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 120").Copy
    Application.Goto Sheets("53").Range("FI37")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 121").Copy
    Application.Goto Sheets("53").Range("FI38")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 122").Copy
    Application.Goto Sheets("53").Range("FI39")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 123").Copy
    Application.Goto Sheets("53").Range("FI40")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 124").Copy
    Application.Goto Sheets("53").Range("FI41")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 125").Copy
    Application.Goto Sheets("53").Range("FI42")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 126").Copy
    Application.Goto Sheets("53").Range("FI43")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 127").Copy
    Application.Goto Sheets("53").Range("FI44")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 128").Copy
    Application.Goto Sheets("53").Range("FI45")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 129").Copy
    Application.Goto Sheets("53").Range("FI46")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 130").Copy
    Application.Goto Sheets("53").Range("FI47")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 131").Copy
    Application.Goto Sheets("53").Range("FI48")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 132").Copy
    Application.Goto Sheets("53").Range("FI49")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 133").Copy
    Application.Goto Sheets("53").Range("FI50")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 134").Copy
    Application.Goto Sheets("53").Range("FI51")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")
    ActiveSheet.Shapes("TextBox 135").Copy
    Application.Goto Sheets("53").Range("FI52")
    ActiveSheet.Paste
    Application.Goto Sheets("Create Blocks").Range("A2")

End Sub

Open in new window

VB ScriptMicrosoft ExcelMicrosoft Office
Avatar of undefined
Last Comment
Trygve Thayer
8/22/2022 - Mon
ASKER CERTIFIED SOLUTION
Martin Liss
THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
Bembi
Hello,
some example code...
As not all Shapes have all properties, you have to make them related to their type.
Shape.Type 12 is a Textbox.

Checks all shapes on the source sheet and copies them to the destination sheet, it they are textboxes with test in it.


Sub Copy_Shape()

Dim shapesCount As Long
Dim snum As Long
Dim curShape As Shape
Dim curShapeText As String
Dim curShapePos As Long

curShapePos = 0

shapesCount = Worksheets("Tabelle1").Shapes.Count
For snum = 1 To shapesCount
    Set curShape = Worksheets("Tabelle1").Shapes(snum)

    If curShape.Type = 12 Then
       curShapeText = Worksheets("Tabelle1").OLEObjects(curShape.Name).Object.Value
    Else
       curShapeText = ""
    End If

    If Len(curShapeText) > 0 Then
        curShapePos = curShapePos + 1
        Worksheets("Tabelle1").Activate
        Worksheets("Tabelle1").Shapes.Range(Array(curShape.Name)).Select
        Selection.Copy

        Worksheets("Tabelle2").Activate
        Worksheets("Tabelle2").Range("A1").Offset(curShapePos, 0).Select
        Worksheets("Tabelle2").Paste
        
    End If
Next
End Sub

Open in new window

Martin Liss
I’m glad I was able to help.

If you expand the “Full Biography" section of my profile you’ll find links to some articles I’ve written that may interest you.

Marty - Microsoft MVP 2009 to 2017
              Experts Exchange Most Valuable Expert (MVE) 2015, 2017
              Experts Exchange Distinguished Expert in Excel 2018
              Experts Exchange Top Expert Visual Basic Classic 2012 to 2020
              Experts Exchange Top Expert VBA 2018 to 2020
Trygve Thayer
ASKER
Thank You !
All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat
William Peck
Plans and Pricing
Resources
Product
Podcasts
Careers
Contact Us
Teams
Certified Expert Program
Credly Partnership
Udemy Partnership
Privacy Policy
Terms of Use

© 1996-2023 Experts Exchange, LLC. All rights reserved. Covered by US Patent