Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reposition Chart Macro
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reposition Chart Macro
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" wrote: 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reposition Chart Macro
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" wrote: 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" wrote: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reposition Chart Macro
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" wrote: 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" wrote: 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" wrote: 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reposition Chart Macro
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" wrote: 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" wrote: 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" wrote: 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" wrote: 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reposition Chart Macro
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" wrote: 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" wrote: 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" wrote: 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" wrote: 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" wrote: 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Reposition Chart Macro
Thanks Joel
All works brilliantly Now I've just got a steep leaning curve understanding it all :) Very much appreciated Graham "Joel" wrote: 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" wrote: 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" wrote: 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" wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
reposition combo box ** | Excel Programming | |||
reposition windows | Excel Discussion (Misc queries) | |||
REPOSITION HIGHEST VALUE ON LINE CHART | Charts and Charting in Excel | |||
ShowWindow and reposition/resize after selecting an embedded chart | Excel Programming | |||
how to reposition a data table in chart | Charts and Charting in Excel |