Resize all charts on a worksheet.

Hi All,

I have the below code which re-sizes all charts on a sheet with one's chart's size. I want to actually give the user a input option where user can enter the width and height in a inputbox and then macro will resize all charts on the sheet with the same size.

Sub ResizeAndArrangeChartObjects()
W = ActiveSheet.ChartObjects("Chart 1").Width
H = ActiveSheet.ChartObjects("Chart 1").Height
TopPos = 0
For Each chtObj In ActiveSheet.ChartObjects
     With chtObj
             .Width = W
             .Height = H
             .Left = 0
             .Top = TopPos
     End With
     TopPos = TopPos + H
Next chtObj
End Sub

'You refer to the chart object something like this:

     ActiveSheet.ChartObjects(1) ' the first chart object in the active sheet

     ActiveSheet.ChartObjects("MyChart") ' a chart that has been named "MyChart"

     ActiveChart.Parent ' the chart object containing the selected chart

'Given that you know your standard sizes, in points (1/72 inch, plus or minus a printer fudge factor of a few 'percent, which is why God invented trial-and-error), you use this kind of approach:

     With ActiveChart.Parent
         .Height = 325 ' resize
         .Width = 500  ' resize
         .Top = 100    ' reposition
         .Left = 100   ' reposition
     End With

'Suppose I want to line up a chart to cover a range in the worksheet. I can do this very easily using a range 'object variable and chartobject variable:

     Sub CoverRangeWithAChart()
         Dim RngToCover As Range
         Dim ChtOb As ChartObject
         Set RngToCover = ActiveSheet.Range("D5:J19")
         Set ChtOb = ActiveChart.Parent
         ChtOb.Height = RngToCover.Height ' resize
         ChtOb.Width = RngToCover.Width   ' resize
         ChtOb.Top = RngToCover.Top       ' reposition
         ChtOb.Left = RngToCover.Left     ' reposition
     End Sub

'You can carry out this procedure a little further, using some of your best 6th grade algebra, to line up the 'charts on your worksheet:

     Sub LineUpMyCharts()
         Dim MyWidth As Single, MyHeight As Single
         Dim NumWide As Long
         Dim iChtIx As Long, iChtCt As Long

         MyWidth = 200
         MyHeight = 150
         NumWide = 3

         iChtCt = ActiveSheet.ChartObjects.Count
         For iChtIx = 1 To iChtCt
             With ActiveSheet.ChartObjects(iChtIx)
                 .Width = MyWidth
                 .Height = MyHeight
                 .Left = ((iChtIx - 1) Mod NumWide) * MyWidth
                 .Top = Int((iChtIx - 1) / NumWide) * MyHeight
             End With
         Next
     End Sub

Thanks a lot for your help in advance.

Hi Abhay,

You should be able to just change two lines of code:

W = InputBox("Enter chart width", "Set Chart Width", 100)
H = InputBox("Enter chart height", "Set Chart Height", 75)

The 100 and 75 will be the default entries, but you can certainly change that (that would actually make a pretty small chart). Error trapping code could (should) be added in case an invalid value is entered (e.g. nothing, or letters).

You can probably just add a loop to go through each sheet in the workbook.

Sub ResizeAndArrangeChartObjects()
Dim W as Long, H as Long, TopPos as Long, ws as Worksheet
W = InputBox("Enter chart width", "Set Chart Width", 100)
H = InputBox("Enter chart height", "Set Chart Height", 75)
TopPos = 0
For Each ws in ThisWorkbook.Worksheets
    For Each chtObj In ws.ChartObjects
        With chtObj
            .Width = W
            .Height = H
            .Left = 0
            .Top = TopPos
        End With
        TopPos = TopPos + H
    Next chtObj
Next ws
End Sub

Try:

Sub ShowChrtSize ()
' Select the active Chart
With ActiveChart.Chartarea
MsgBox "Width: " & .Width & ", height: " & .Height
End With

End Sub

Hi All,

I have the below macro which loops through all sheets in a workbook and resizes the charts in the each sheet as per the size entered by user but It doesn't show a msgbox with text "that it didn't find any chart on a particular sheet". I want to put some code that it will show that it didn't find the charts in which all sheets at last the macro run gets completed.

Code to resize charts in multiple sheets:

Sub ResizeAndArrangeChartObjects()
Dim W as Long, H as Long, TopPos as Long, ws as Worksheet
W = InputBox("Enter chart width", "Set Chart Width", 100)
H = InputBox("Enter chart height", "Set Chart Height", 75)
TopPos = 0
For Each ws in ThisWorkbook.Worksheets
    For Each chtObj In ws.ChartObjects
        With chtObj
            .Width = W
            .Height = H
            .Left = 0
            .Top = TopPos
        End With
        TopPos = TopPos + H
    Next chtObj
Next ws
End Sub

Code to resize charts in activesheet:

Sub ResizeAndArrangeChartObjects()
W = ActiveSheet.ChartObjects("Chart 1").Width
H = ActiveSheet.ChartObjects("Chart 1").Height
TopPos = 0
For Each chtObj In ActiveSheet.ChartObjects
     With chtObj
             .Width = W
             .Height = H
             .Left = 0
             .Top = TopPos
     End With
     TopPos = TopPos + H
Next chtObj
End Sub

Thanks a lot for your help in advance.