iamaichgee
09-28-2016, 04:59 PM
Hi VBA Express,
I'm sort of a newbie in VBA and I'm trying to build a macro that draws a diagram which shades in portions of segments depending on certain values in the excel spreadsheet. Here's what I currently have:
Sub CreateChart()
' Remove the current diagram on Sheet 1
RemoveOtherShapes
' Take a copy of the original diagram and place in main worksheet
CopyNewShape
' Now apply the scale for each piece
Dim nScale As Double
'Segment1
nScale = Worksheets(1).Cells(2, 2)
ActiveSheet.Shapes("Segment1").ScaleHeight nScale, msoFalse, msoScaleFromBottomRight
ActiveSheet.Shapes("Segment1").ScaleWidth nScale, msoFalse, msoScaleFromBottomRight
Call MoveSideSegmentsBack(nScale, 2)
'Segment2
nScale = Worksheets(1).Cells(3, 2)
ActiveSheet.Shapes(6).ScaleHeight nScale, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes(6).ScaleWidth nScale, msoFalse, msoScaleFromTopLeft
Call MoveSideSegmentsBack(nScale, 6)
'Segment3
nScale = Worksheets(1).Cells(4, 2)
ActiveSheet.Shapes(5).ScaleHeight nScale, msoFalse, msoScaleFromBottomRight
ActiveSheet.Shapes(5).ScaleWidth nScale, msoFalse, msoScaleFromTopLeft
Call MoveSideSegmentsBack(nScale, 5)
'Segment4
nScale = Worksheets(1).Cells(5, 2)
ActiveSheet.Shapes(3).ScaleHeight nScale, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes(3).ScaleWidth nScale, msoFalse, msoScaleFromBottomRight
Call MoveSideSegmentsBack(nScale, 3)
'Segment5
nScale = Worksheets(1).Cells(6, 2)
ActiveSheet.Shapes(4).ScaleWidth nScale, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes(4).ScaleHeight nScale, msoFalse, msoScaleFromTopLeft
Call MoveSideSegmentsBack(nScale, 4)
GroupPieces
End Sub
Sub GroupPieces()
ActiveSheet.Shapes.Range(Array("Segment1", "Segment2", "Segment3", _
"Segment4", "Segment5", _
"Main")).Select
Selection.ShapeRange.Group.Select
Selection.Name = "WLMCS tool"
End Sub
Sub RemoveOtherShapes()
Dim oShape As Shape
Worksheets(1).Activate
For Each oShape In ActiveSheet.Shapes
If oShape.Name = "cmd_DrawChart" Then
'Do Nothing
ElseIf oShape.Name = "cmd_PrintChart" Then
'Do Nothing
Else
oShape.Delete
End If
Next oShape
End Sub
Sub CopyNewShape()
Worksheets(2).Activate
ActiveSheet.Shapes.SelectAll
' Range(Array("Main", "Segment1", "Segment2", "Segment3", _
' "Segment4", "Segment5")).Select
Selection.Copy
Worksheets(1).Activate
Range("F5").Select
ActiveSheet.Paste
End Sub
Sub MoveSideSegmentsBack(nScale As Double, Shape As Integer)
ActiveSheet.Shapes(Shape).Select
If nScale = 0.8 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -42
Selection.ShapeRange.IncrementLeft 28
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -32
Selection.ShapeRange.IncrementLeft 66
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 30
Selection.ShapeRange.IncrementLeft -40
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 64
Selection.ShapeRange.IncrementLeft -36
End If
ElseIf nScale = 0.6 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -85
Selection.ShapeRange.IncrementLeft 59
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -63
Selection.ShapeRange.IncrementLeft 131
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 60
Selection.ShapeRange.IncrementLeft -80
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 127
Selection.ShapeRange.IncrementLeft -71
End If
ElseIf nScale = 0.4 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -128
Selection.ShapeRange.IncrementLeft 91
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -94
Selection.ShapeRange.IncrementLeft 197
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 89
Selection.ShapeRange.IncrementLeft -121
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 182
Selection.ShapeRange.IncrementLeft -105
End If
ElseIf nScale = 0.2 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -171
Selection.ShapeRange.IncrementLeft 122
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -125
Selection.ShapeRange.IncrementLeft 263
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 119
Selection.ShapeRange.IncrementLeft -161
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 237
Selection.ShapeRange.IncrementLeft -139
End If
End If
End Sub
' 'Rename objects
'
'' ActiveSheet.Shapes(3).Select
'' Selection.Name = "What Levers Make Change Stick"
'' ActiveSheet.Shapes(4).Select
'' Selection.Name = "Segment 1"
'' ActiveSheet.Shapes(5).Select
'' Selection.Name = "Segment 2"
'' ActiveSheet.Shapes(6).Select
'' Selection.Name = "Segment 3"
'' ActiveSheet.Shapes(7).Select
'' Selection.Name = "Segment 4"
'' ActiveSheet.Shapes(8).Select
'' Selection.Name = "Segment 5"
'' ActiveSheet.Shapes(9).Select
'' Selection.Name = "Segment 6"
'
It's giving me an index error and I'm not too sure why.
I got the shapes' index by trial and erroring.
I've tried playing around using different naming conventions - e.g. between Shapes(2) & Shapes("Segment1").
Both give me errors but different errors.
Thanks in advance.
I'm sort of a newbie in VBA and I'm trying to build a macro that draws a diagram which shades in portions of segments depending on certain values in the excel spreadsheet. Here's what I currently have:
Sub CreateChart()
' Remove the current diagram on Sheet 1
RemoveOtherShapes
' Take a copy of the original diagram and place in main worksheet
CopyNewShape
' Now apply the scale for each piece
Dim nScale As Double
'Segment1
nScale = Worksheets(1).Cells(2, 2)
ActiveSheet.Shapes("Segment1").ScaleHeight nScale, msoFalse, msoScaleFromBottomRight
ActiveSheet.Shapes("Segment1").ScaleWidth nScale, msoFalse, msoScaleFromBottomRight
Call MoveSideSegmentsBack(nScale, 2)
'Segment2
nScale = Worksheets(1).Cells(3, 2)
ActiveSheet.Shapes(6).ScaleHeight nScale, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes(6).ScaleWidth nScale, msoFalse, msoScaleFromTopLeft
Call MoveSideSegmentsBack(nScale, 6)
'Segment3
nScale = Worksheets(1).Cells(4, 2)
ActiveSheet.Shapes(5).ScaleHeight nScale, msoFalse, msoScaleFromBottomRight
ActiveSheet.Shapes(5).ScaleWidth nScale, msoFalse, msoScaleFromTopLeft
Call MoveSideSegmentsBack(nScale, 5)
'Segment4
nScale = Worksheets(1).Cells(5, 2)
ActiveSheet.Shapes(3).ScaleHeight nScale, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes(3).ScaleWidth nScale, msoFalse, msoScaleFromBottomRight
Call MoveSideSegmentsBack(nScale, 3)
'Segment5
nScale = Worksheets(1).Cells(6, 2)
ActiveSheet.Shapes(4).ScaleWidth nScale, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes(4).ScaleHeight nScale, msoFalse, msoScaleFromTopLeft
Call MoveSideSegmentsBack(nScale, 4)
GroupPieces
End Sub
Sub GroupPieces()
ActiveSheet.Shapes.Range(Array("Segment1", "Segment2", "Segment3", _
"Segment4", "Segment5", _
"Main")).Select
Selection.ShapeRange.Group.Select
Selection.Name = "WLMCS tool"
End Sub
Sub RemoveOtherShapes()
Dim oShape As Shape
Worksheets(1).Activate
For Each oShape In ActiveSheet.Shapes
If oShape.Name = "cmd_DrawChart" Then
'Do Nothing
ElseIf oShape.Name = "cmd_PrintChart" Then
'Do Nothing
Else
oShape.Delete
End If
Next oShape
End Sub
Sub CopyNewShape()
Worksheets(2).Activate
ActiveSheet.Shapes.SelectAll
' Range(Array("Main", "Segment1", "Segment2", "Segment3", _
' "Segment4", "Segment5")).Select
Selection.Copy
Worksheets(1).Activate
Range("F5").Select
ActiveSheet.Paste
End Sub
Sub MoveSideSegmentsBack(nScale As Double, Shape As Integer)
ActiveSheet.Shapes(Shape).Select
If nScale = 0.8 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -42
Selection.ShapeRange.IncrementLeft 28
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -32
Selection.ShapeRange.IncrementLeft 66
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 30
Selection.ShapeRange.IncrementLeft -40
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 64
Selection.ShapeRange.IncrementLeft -36
End If
ElseIf nScale = 0.6 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -85
Selection.ShapeRange.IncrementLeft 59
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -63
Selection.ShapeRange.IncrementLeft 131
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 60
Selection.ShapeRange.IncrementLeft -80
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 127
Selection.ShapeRange.IncrementLeft -71
End If
ElseIf nScale = 0.4 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -128
Selection.ShapeRange.IncrementLeft 91
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -94
Selection.ShapeRange.IncrementLeft 197
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 89
Selection.ShapeRange.IncrementLeft -121
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 182
Selection.ShapeRange.IncrementLeft -105
End If
ElseIf nScale = 0.2 Then
If Shape = 2 Then
'do nothing
ElseIf Shape = 3 Then
Selection.ShapeRange.IncrementTop -171
Selection.ShapeRange.IncrementLeft 122
ElseIf Shape = 4 Then
Selection.ShapeRange.IncrementTop -125
Selection.ShapeRange.IncrementLeft 263
ElseIf Shape = 5 Then
Selection.ShapeRange.IncrementTop 119
Selection.ShapeRange.IncrementLeft -161
ElseIf Shape = 6 Then
Selection.ShapeRange.IncrementTop 237
Selection.ShapeRange.IncrementLeft -139
End If
End If
End Sub
' 'Rename objects
'
'' ActiveSheet.Shapes(3).Select
'' Selection.Name = "What Levers Make Change Stick"
'' ActiveSheet.Shapes(4).Select
'' Selection.Name = "Segment 1"
'' ActiveSheet.Shapes(5).Select
'' Selection.Name = "Segment 2"
'' ActiveSheet.Shapes(6).Select
'' Selection.Name = "Segment 3"
'' ActiveSheet.Shapes(7).Select
'' Selection.Name = "Segment 4"
'' ActiveSheet.Shapes(8).Select
'' Selection.Name = "Segment 5"
'' ActiveSheet.Shapes(9).Select
'' Selection.Name = "Segment 6"
'
It's giving me an index error and I'm not too sure why.
I got the shapes' index by trial and erroring.
I've tried playing around using different naming conventions - e.g. between Shapes(2) & Shapes("Segment1").
Both give me errors but different errors.
Thanks in advance.