PDA

View Full Version : Generate Shapes, Align, Group, Cut and Paste



peterwmartin
05-05-2016, 10:47 PM
Hi all I am trying to generate shapes align,group cut and place.
I need this to happen on sheet 2 then copy and paste to sheet1.
I had this working from a cell reference, however when I try it from a userform, it does not work.


Private Sub CommandButton1_Click()
Sheets("Sheet2").Shapes.AddShape msoShapeRoundedRectangle, 1, 1, 10, 50
'ActiveSheet.Shapes.SelectAll
For x = 1 To UserForm1.TextBox1.Value - 1


Selection.Copy
Paste




Next x
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Align msoAlignTops, True
Selection.ShapeRange.Group.Name = "Group99"


Sheets("Sheet1").Shapes("Group99").Copy
Application.Goto Sheets("Sheet2").Range("g5")
ActiveSheet.Paste
Sheets("Sheet1").Shapes("Group99").Left = 150
Sheets("Sheet1").Shapes("Group99").Top = 100
Sheets("Sheet1").Shapes("Group99").Fill.ForeColor.RGB = RGB(255, 240, 255)
Sheets("Sheet1").Shapes("Group99").Fill.Transparency = 0.2
Sheets("Sheet1").Shapes("Group99").Line.ForeColor.RGB = RGB(100, 0, 100)
Sheets("Sheet1").Shapes("Group99").Line.Weight = 0.25
End Sub

I go from one error to the next, I would also like the shapes to be next to each other without any space.
Any help would be appreciated
Cheers

p45cal
05-06-2016, 03:53 AM
loads of assumptions made (you don't need to name the group, you don't need to prepare the group on a different sheet first) so this may not fit the bill but try:
Private Sub CommandButton1_Click()
Dim newshp As Shape
n = UserForm1.TextBox1.Value - 1
If n > 0 Then
With Sheets("Sheet1")
myleft = .Range("G5").Left
mytop = .Range("G5").Top
ReDim aryShpNms(1 To n)
For x = 1 To n
If Not newshp Is Nothing Then myleft = newshp.Left + newshp.Width
Set newshp = .Shapes.AddShape(msoShapeRoundedRectangle, myleft, mytop, 10, 50)
aryShpNms(x) = .Shapes.Count
Next x
Set ShRange = .Shapes.Range(aryShpNms)
If n > 1 Then Set ShRange = ShRange.Group
With ShRange
.Fill.ForeColor.RGB = RGB(255, 240, 255)
.Fill.Transparency = 0.2
.Line.ForeColor.RGB = RGB(100, 0, 100)
.Line.Weight = 0.25
End With
End With
End If
End SubIf cell G5 is irrelevant in your code then adjust to:
myleft = 150
mytop = 100

peterwmartin
05-06-2016, 04:39 AM
Thanks for the help gave it a try, problems with this line

If n > 1 Then Set ShRange = ShRange.Group
Trying to work through it cheers

peterwmartin
05-06-2016, 04:42 AM
This is also what I want, same thing it is so close except for the last line.

Sub CreateAutoshapes() Dim i As Integer
Dim t As Integer
Dim shp As Shape


t = 10
For i = 1 To 10
Set shp = Sheets("sheet6").Shapes.AddShape(5, t, 5, 10, 60)
'shp.TextFrame.Characters.Text = i
t = t + 11
Next




End Sub




Sub select_move()
Sheets("Sheet6").Shapes.SelectAll
'Selection.ShapeRange.Align msoAlignTops, True
Selection.ShapeRange.Group.Name = "Group99"


'Sheets("Sheet6").Shapes("Group99").Copy
'Sheets("Sheet5").Select
'PasteSpecial
Sheets("Sheet6").Shapes("Group99").Left = 150
Sheets("Sheet6").Shapes("Group99").Top = 100
Sheets("Sheet6").Shapes("Group99").Fill.ForeColor.RGB = RGB(255, 240, 255)
Sheets("Sheet6").Shapes("Group99").Fill.Transparency = 0.2
Sheets("Sheet6").Shapes("Group99").Line.ForeColor.RGB = RGB(100, 0, 100)
Sheets("Sheet6").Shapes("Group99").Line.Weight = 0.25


Sheets("Sheet6").Shapes("Group99").Copy


ThisWorkbook.Sheets("Sheet5").Paste Destination:=ThisWorkbook.Sheets("Sheet5").Range("A1")
End Sub

p45cal
05-06-2016, 05:02 AM
Thanks for the help gave it a try, problems with this line

If n > 1 Then Set ShRange = ShRange.Group
Trying to work through it cheersWhat's the value of n at the time? What was in the textbox at the time? What was the error message exactly?
n is UserForm1.TextBox1.Value - 1 so if the textbox doesn't contain a number, or has text or nothing then it might go wrong.

peterwmartin
05-06-2016, 05:10 AM
I had 5 in the textbox
runtime error 1004
application-defined or object-defined error

p45cal
05-06-2016, 05:33 AM
I can't reproduce this error on my machine. Attach your file here?

peterwmartin
05-06-2016, 05:49 AM
hope thats correct
16113

thanks for the help, the second code I put up may be easier, just searching more info on the last line before end sub

p45cal
05-06-2016, 06:05 AM
my code seems fine in attached.

peterwmartin
05-06-2016, 06:12 AM
Thanks so much for the help,
still getting the same error, will try it on another computer with office 2010 tomorrow and will see if I still get the problem.
I will let you know how it goes, I m currently using 2007.
Cheers

peterwmartin
05-06-2016, 03:00 PM
Yes it worked perfectly, thanks so much for the help
Cheers

peterwmartin
05-07-2016, 03:33 PM
Hi p45cal, still getting the error

If n > 1 Then Set ShRange = ShRange.Group
I have added other shapes etc to the sheet and move them around with scrollbars, change Z order etc works fine. However when I add another group sometimes i get the error back, have removed new group and still the error will return. Searching for help on line, trying on error resume etc. Any further thoughts would be appreciated. Cheers

p45cal
05-07-2016, 03:44 PM
Since I can't reproduce the error here, the only way might be a TeamViewer session? I'm in the UK.

peterwmartin
05-07-2016, 03:53 PM
Team viewer session?

p45cal
05-07-2016, 04:13 PM
LMGTFY: https://www.google.co.uk/search?q=TeamViewer&ie=utf-8&oe=utf-8&client=firefox-b&gfe_rd=cr&ei=i3YuV-W6Ge7R8gfZj4jADA