Resize all charts but restrict to defined range....

[BuJay]

I have the below code that resizes all charts in a sheet. Is there a way to apply this code to only those charts captured in the range Row 4 through Row 213, for example?

The reason I ask is I want charts in rows 4 through 213 to have consistent shape, but there are a set of charts in rows 214 and lower that need to be a different size, so the macro below changes them and I don't want it to do so.

Sub resize_all_charts()

    Dim counter As Integer
    
    'Loop through all of the charts
    For counter = 1 To ActiveSheet.ChartObjects.Count
    
        'Change the Height and Width values based on your requirements
        With ActiveSheet.ChartObjects(counter)
            .Height = 195
            .Width = 432
        End With
        
    Next counter
    
End Sub

 

[BuJay]

Sub ResizeChartsInRange1()

    Dim chtObj As ChartObject
    Dim rngRestrict As Range
    
    ' Set the range to restrict resizing
    Set rngRestrict = ActiveSheet.Range("4:213")
    
    ' Loop through each chart in the active sheet
    For Each chtObj In ActiveSheet.ChartObjects
        ' Check if the chart intersects with the restricted range
        If Not Intersect(chtObj.TopLeftCell, rngRestrict) Is Nothing Then
            ' Resize the chart
            chtObj.Height = 195
            chtObj.Width = 432
        End If
    Next chtObj

    Set rngRestrict = ActiveSheet.Range("214:241")

    ' Loop through each chart in the active sheet
    For Each chtObj In ActiveSheet.ChartObjects
        ' Check if the chart intersects with the restricted range
        If Not Intersect(chtObj.TopLeftCell, rngRestrict) Is Nothing Then
            ' Resize the chart
            chtObj.Height = 405
            chtObj.Width = 873
        End If
    Next chtObj

    Set rngRestrict = ActiveSheet.Range("242:270")

    ' Loop through each chart in the active sheet
    For Each chtObj In ActiveSheet.ChartObjects
        ' Check if the chart intersects with the restricted range
        If Not Intersect(chtObj.TopLeftCell, rngRestrict) Is Nothing Then
            ' Resize the chart
            chtObj.Height = 195
            chtObj.Width = 873
        End If
    Next chtObj

    Set rngRestrict = ActiveSheet.Range("270:326")

    ' Loop through each chart in the active sheet
    For Each chtObj In ActiveSheet.ChartObjects
        ' Check if the chart intersects with the restricted range
        If Not Intersect(chtObj.TopLeftCell, rngRestrict) Is Nothing Then
            ' Resize the chart
            chtObj.Height = 405
            chtObj.Width = 873
        End If
    Next chtObj
    
    Set rngRestrict = ActiveSheet.Range("326:354")

    ' Loop through each chart in the active sheet
    For Each chtObj In ActiveSheet.ChartObjects
        ' Check if the chart intersects with the restricted range
        If Not Intersect(chtObj.TopLeftCell, rngRestrict) Is Nothing Then
            ' Resize the chart
            chtObj.Height = 195
            chtObj.Width = 873
        End If
    Next chtObj
    
    Set rngRestrict = ActiveSheet.Range("354:382")

    ' Loop through each chart in the active sheet
    For Each chtObj In ActiveSheet.ChartObjects
        ' Check if the chart intersects with the restricted range
        If Not Intersect(chtObj.TopLeftCell, rngRestrict) Is Nothing Then
            ' Resize the chart
            chtObj.Height = 405
            chtObj.Width = 873
        End If
    Next chtObj
    
End Sub

 

[Domenic]

For what it's worth, your macro can be re-written as follows...

Sub ResizeChartsInRange1()

    Dim restrictDictionary As Object
    Dim restrictKey As Variant
    Dim restrictItem As Variant
    Dim chtObj As ChartObject
    
    Set restrictDictionary = CreateObject("Scripting.Dictionary")
    
    With restrictDictionary
        .Add Key:="4:213", Item:="195;432"
        .Add Key:="214:241", Item:="405;873"
        .Add Key:="242:270", Item:="195;873"
        .Add Key:="270:326", Item:="405;873"
        .Add Key:="326:354", Item:="195;873"
        .Add Key:="354:382", Item:="405;873"
    End With
    
    For Each chtObj In ActiveSheet.ChartObjects
        For Each restrictKey In restrictDictionary.Keys()
            If Not Intersect(chtObj.TopLeftCell, Range(restrictKey)) Is Nothing Then
                restrictItem = restrictDictionary(restrictKey)
                With chtObj
                    .Height = Split(restrictItem, ";")(0)
                    .Width = Split(restrictItem, ";")(1)
                End With
                Exit For
            End If
        Next restrictKey
    Next chtObj

End Sub

Hope this helps!