Reposition Chart Macro

[Graham]

Hi

I am trying to automate a particularly mundane task.

I have a running 6 months of charts on each page repeated for 15 different
criteria.
Currenlty I have to delete the oldest and reposition the remainder to free
up space for the latest month's chart.

I have recorded a macro which reflects this task but obviously needs to be
modified as it selects specific charts.

Can the following code be amended to select charts by their position on the
page?

ActiveSheet.ChartObjects("Chart 21").Activate
ActiveChart.ChartArea.Select
ActiveWindow.Visible = False
Selection.Delete
ActiveSheet.ChartObjects("Chart 44").Activate
ActiveChart.ChartArea.Select
ActiveWindow.Visible = False
Windows("Copy of Insurer MI Report v1.06.xls").Activate
ActiveSheet.Shapes.Range(Array("Chart 44", "Chart 61")).Select
Selection.ShapeRange.IncrementLeft -336#
ActiveSheet.ChartObjects("Chart 76").Activate
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Chart 76").IncrementLeft 670.5
ActiveSheet.Shapes("Chart 76").IncrementTop -331.5

Any suggestions would be very much appreciated

 

[Joel]

Interesting problem!!! Since the charts are not in any order on the sheet
you first have to sort the charts according to there position. I made the
code general incase it need to be expanded for my charts.

I assumed the order of the charts where from left to right, and then up to
down. I also assumed yo want to put the charts in the exact same postion the
when you are done. I also used shapes as the object since charts are shapes.
there may be a problem if there are other object on the sheet. I found the
positions of all the shapes in an array including the shape name, left, and
top position. the performed two sorts to get the array in the correct order.
See code below.


Sub movecharts()

Dim MyShapes()

NumShapes = Shapes.Count
ReDim MyShapes(0 To NumShapes - 1, 0 To 2)
Shapecount = 0
For Each Shape In Shapes
MyShapes(Shapecount, 0) = Shape.Top
MyShapes(Shapecount, 1) = Shape.Left
MyShapes(Shapecount, 2) = Shape.Name

Shapecount = Shapecount + 1
Next Shape

'sort so order is
' 0 = top left
' 1 = top right
' 2 = bottom left
' 3 = bottom right

'code below was written so it would be easily
'modified for more chart

'bubble sort by top parameter
For i = 0 To (NumShapes - 2)
For j = (i + 1) To (NumShapes - 1)
If MyShapes(j, 0) < MyShapes(i, 0) Then
'swap shapes in array
For k = 0 To 2
Temp = MyShapes(i, k)
MyShapes(i, k) = MyShapes(j, k)
MyShapes(j, k) = Temp
Next k
End If

Next j
Next i

'Repeat for number of rows
For h = 1 To 2
'bubble sort by left parameter
For i = 0 To 2 Step 2
For j = (i + 1) To (i + 1)
If MyShapes(j, 1) < MyShapes(i, 1) Then
'swap shapes in array
For k = 0 To 2
Temp = MyShapes(i, k)
MyShapes(i, k) = MyShapes(j, k)
MyShapes(j, k) = Temp
Next k
End If
Next j
Next i
Next h

'now move charts
' put chart 1 in chart 0 psoition and etc
Set FirstShape = Shapes(MyShapes(0, 2))
FirstShape.Delete
For Shapecount = 0 To (NumShapes - 2)
Set NextShape = Shapes(MyShapes(Shapecount + 1, 2))
With NextShape
.Top = MyShapes(Shapecount, 0)
.Left = MyShapes(Shapecount, 1)
End With
Next Shapecount

End Sub

 

[Graham]

Thanks for the reply.

Had a good look through and think I understand.

Unfortunately the code errors (object required) at
NumShapes = Shapes.Count
Does this need to be declared?

 

[Joel]

I originally tested the code using pictures instead of charts on my PC at
home and everything worked. At work I got the same error that you did.
found by putting Activesheet before Sheets removed the error. Not sure why.

I also added a message box to indicate number of shapes being moved. There
are other objects you may have on you wroksheet that will be considered
shaped. Want to find out if I have to filter the code to look at only charts.


Sub movecharts()

Dim MyShapes()

NumShapes = ActiveSheet.Shapes.Count
msgbox("Moving " & NumShapes & " Shapes")
ReDim MyShapes(0 To NumShapes - 1, 0 To 2)
Shapecount = 0
For Each Shp In ActiveSheet.Shapes
MyShapes(Shapecount, 0) = Shp.Top
MyShapes(Shapecount, 1) = Shp.Left
MyShapes(Shapecount, 2) = Shp.Name

Shapecount = Shapecount + 1
Next Shp

'sort so order is
' 0 = top left
' 1 = top right
' 2 = bottom left
' 3 = bottom right

'code below was written so it would be easily
'modified for more chart

'bubble sort by top parameter
For i = 0 To (NumShapes - 2)
For j = (i + 1) To (NumShapes - 1)
If MyShapes(j, 0) < MyShapes(i, 0) Then
'swap shapes in array
For k = 0 To 2
Temp = MyShapes(i, k)
MyShapes(i, k) = MyShapes(j, k)
MyShapes(j, k) = Temp
Next k
End If

Next j
Next i

'Repeat for number of rows
For h = 1 To 2
'bubble sort by left parameter
For i = 0 To 2 Step 2
For j = (i + 1) To (i + 1)
If MyShapes(j, 1) < MyShapes(i, 1) Then
'swap shapes in array
For k = 0 To 2
Temp = MyShapes(i, k)
MyShapes(i, k) = MyShapes(j, k)
MyShapes(j, k) = Temp
Next k
End If
Next j
Next i
Next h

'now move charts
' put chart 1 in chart 0 psoition and etc
Set FirstShape = ActiveSheet.Shapes(MyShapes(0, 2))
FirstShape.Delete
For Shapecount = 0 To (NumShapes - 2)
Set NextShape = ActiveSheet.Shapes(MyShapes(Shapecount + 1, 2))
With NextShape
.Top = MyShapes(Shapecount, 0)
.Left = MyShapes(Shapecount, 1)
End With
Next Shapecount

End Sub

 

[Graham]

Thanks Joel

The macro now works fine (no non chart shapes on the page to worry about)

Can you point me in the right direction to modify the code for 6 charts (3
across, 2 down)
I assume the array needs to be changed as well as the swap order but I'm
getting a little confused.

thanks
Graham

 

[Joel]

I tested the code by using the clip art Billard Balls placing nine balls on
the worksheet. Worked Great. There were some minor bugs in the old code
that weren't noticable but I found when I went to a larger array. I added a
new variable ChartAcross so the code will work under ANY condition. The last
item in the arrray
MyShapes is the left and top position where you should place the new chart
if that step part of the macro.

MyShapes(NumShapes - 1, 0) The Top position of the new shape
MyShapes(NumShapes - 1, 1) The Left position of the new shape


I even test the code where the last row didn't have all the balls. I didn't
work the first time I tried with 10 ball with 3 balls in each row. I fixed
the problem.

Sub MoveCharts()

Dim MyShapes()
NumShapes = ActiveSheet.Shapes.Count

ChartsAcross = 3
ChartsDown = WorksheetFunction.RoundUp(NumShapes / ChartsAcross, 0)

MsgBox ("Moving " & NumShapes & " Shapes")
ReDim MyShapes(0 To NumShapes - 1, 0 To 2)
ShapeCount = 0
For Each Shp In ActiveSheet.Shapes
MyShapes(ShapeCount, 0) = Shp.Top
MyShapes(ShapeCount, 1) = Shp.Left
MyShapes(ShapeCount, 2) = Shp.Name

ShapeCount = ShapeCount + 1
Next Shp

'sort so order is
' 0 = top left
' 1 = top right
' 2 = bottom left
' 3 = bottom right

'code below was written so it would be easily
'modified for more chart

'bubble sort by top parameter
For i = 0 To (NumShapes - 2)
For j = (i + 1) To (NumShapes - 1)
If MyShapes(j, 0) < MyShapes(i, 0) Then
'swap shapes in array
For k = 0 To 2
Temp = MyShapes(i, k)
MyShapes(i, k) = MyShapes(j, k)
MyShapes(j, k) = Temp
Next k
End If

Next j
Next i

'Repeat for number of rows
For RowCount = 0 To (ChartsDown - 1)
'bubble sort rows by left parameter
FirstChart = RowCount * ChartsAcross
LastChart = ((RowCount + 1) * ChartsAcross) - 1
If LastChart > UBound(MyShapes) Then
LastChart = UBound(MyShapes)
End If
For i = FirstChart To (LastChart - 1)
For j = (i + 1) To LastChart
If MyShapes(j, 1) < MyShapes(i, 1) Then
'swap shapes in array
For k = 0 To 2
Temp = MyShapes(i, k)
MyShapes(i, k) = MyShapes(j, k)
MyShapes(j, k) = Temp
Next k
End If
Next j
Next i
Next RowCount

'now move charts
' put chart 1 in chart 0 psoition and etc
Set FirstShape = ActiveSheet.Shapes(MyShapes(0, 2))
FirstShape.Delete
For ShapeCount = 0 To (NumShapes - 2)
Set NextShape = ActiveSheet.Shapes(MyShapes(ShapeCount + 1, 2))
With NextShape
.Top = MyShapes(ShapeCount, 0)
.Left = MyShapes(ShapeCount, 1)
End With
Next ShapeCount

End Sub

 

[Graham]

Thanks Joel
All works brilliantly

Now I've just got a steep leaning curve understanding it all

Very much appreciated

Graham