excel2003 AutoShapes

nodari

Board Regular
Joined
Jan 8, 2010
Messages
224
in my VBA code I need to get texts from the spapes selected by user. it's easy, if it's selected only 1 shape, but if selected 2 or more, I have problem.

can anyone advice me anything?
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,303
Maybe something like this... Select the desired shapes from the worksheet, then run the following macro. For each selected shape, the macro places the name of the shape in Column A and the corresponding text in Column B in Sheet2 (change as desired in the code)...

Code:
[font=Verdana][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] GetText()

    [color=darkblue]Dim[/color] wksDest [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] shp [color=darkblue]As[/color] Shape
    [color=darkblue]Dim[/color] ShpCount [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] r [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color]
    ShpCount = Selection.ShapeRange.Count
    [color=darkblue]If[/color] Err.Number <> 0 [color=darkblue]Then[/color]
        MsgBox "No shapes have been selected...", vbExclamation
        [color=darkblue]Exit[/color] [color=darkblue]Sub[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] 0
    
    Application.ScreenUpdating = [color=darkblue]False[/color]
    
    [color=green]'Change the destination sheet accordingly[/color]
    [color=darkblue]Set[/color] wksDest = Worksheets("Sheet2")

    [color=darkblue]For[/color] [color=darkblue]Each[/color] shp [color=darkblue]In[/color] Selection.ShapeRange
        [color=darkblue]With[/color] wksDest
            r = r + 1
            .Cells(r, "A").Value = shp.Name
            .Cells(r, "B").Value = shp.TextFrame.Characters.Text
        [color=darkblue]End[/color] [color=darkblue]With[/color]
    [color=darkblue]Next[/color] shp
    
    wksDest.Columns("A:B").AutoFit
    
    Application.ScreenUpdating = [color=darkblue]True[/color]
    
    MsgBox "Text from " & ShpCount & " shapes have been extracted...", vbInformation
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]
 

nodari

Board Regular
Joined
Jan 8, 2010
Messages
224
Maybe something like this... Select the desired shapes from the worksheet, then run the following macro. For each selected shape, the macro places the name of the shape in Column A and the corresponding text in Column B in Sheet2 (change as desired in the code)...

Code:
[FONT=Verdana][COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=darkblue]Sub[/COLOR] GetText()[/FONT]
 
[FONT=Verdana]   [COLOR=darkblue]Dim[/COLOR] wksDest [COLOR=darkblue]As[/COLOR] Worksheet[/FONT]
[FONT=Verdana]   [COLOR=darkblue]Dim[/COLOR] shp [COLOR=darkblue]As[/COLOR] Shape[/FONT]
[FONT=Verdana]   [COLOR=darkblue]Dim[/COLOR] ShpCount [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR][/FONT]
[FONT=Verdana]   [COLOR=darkblue]Dim[/COLOR] r [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR][/FONT]
 
[FONT=Verdana]   [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR][/FONT]
[FONT=Verdana]   ShpCount = Selection.ShapeRange.Count[/FONT]
[FONT=Verdana]   [COLOR=darkblue]If[/COLOR] Err.Number <> 0 [COLOR=darkblue]Then[/COLOR][/FONT]
[FONT=Verdana]       MsgBox "No shapes have been selected...", vbExclamation[/FONT]
[FONT=Verdana]       [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR][/FONT]
[FONT=Verdana]   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR][/FONT]
[FONT=Verdana]   [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0[/FONT]
 
[FONT=Verdana]   Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR][/FONT]
 
[FONT=Verdana]   [COLOR=green]'Change the destination sheet accordingly[/COLOR][/FONT]
[FONT=Verdana]   [COLOR=darkblue]Set[/COLOR] wksDest = Worksheets("Sheet2")[/FONT]
 
[FONT=Verdana]   [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] shp [COLOR=darkblue]In[/COLOR] Selection.ShapeRange[/FONT]
[FONT=Verdana]       [COLOR=darkblue]With[/COLOR] wksDest[/FONT]
[FONT=Verdana]           r = r + 1[/FONT]
[FONT=Verdana]           .Cells(r, "A").Value = shp.Name[/FONT]
[FONT=Verdana]           .Cells(r, "B").Value = shp.TextFrame.Characters.Text[/FONT]
[FONT=Verdana]       [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR][/FONT]
[FONT=Verdana]   [COLOR=darkblue]Next[/COLOR] shp[/FONT]
 
[FONT=Verdana]   wksDest.Columns("A:B").AutoFit[/FONT]
 
[FONT=Verdana]   Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR][/FONT]
 
[FONT=Verdana]   MsgBox "Text from " & ShpCount & " shapes have been extracted...", vbInformation[/FONT]
 
[FONT=Verdana][COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR][/FONT]

thank you very much, I found in this code what I needed.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,000
Messages
5,526,172
Members
409,685
Latest member
Bellybb

This Week's Hot Topics

Top