Make VBA more efficient/ elegant?

[tabbytomo]

Hiya, I've got some VBA that will filter on a value, select the range of values available within that filter, copy the range, paste into a chart and export the chart as a jpg. My current code is simply copy/ pasted for each filter I want it to do that for. With 93 filters I want it to work through, this code is going to become huge! Is there a way to make this more efficient? The below is an example of it working between two of the filters...only 91 to go.

Sub SelectTeams()
    Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
    Dim fileSaveName As Variant, pic As Variant
    
    'Select Team 1
    
Sheets("Team Performance").Select
        Range("$A$1:$Y$1500").AutoFilter Field:=15, Criteria1:= _
        "Team 1"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    
    'Create and save the image section!!!!
    
    'Create temporary chart as canvas
    Set sht = Selection.Worksheet
    Selection.Copy
    sht.Pictures.Paste.Select
    Set sh = sht.Shapes(sht.Shapes.Count)
    Set tmpChart = Charts.Add
    tmpChart.ChartArea.Clear
    tmpChart.Name = "PicChart" & (Rnd() * 10000)
    Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
    tmpChart.ChartArea.Width = sh.Width
    tmpChart.ChartArea.Height = sh.Height
    tmpChart.Parent.Border.LineStyle = 0
    'Paste range as image to chart
    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste
    'Save chart image to file
    fileSaveName = "C:\Users\tabbytomo\Desktop\Team1.jpg"
      tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
    'Clean up
    sht.Cells(1, 1).Activate
    sht.ChartObjects(sht.ChartObjects.Count).Delete
    sh.Delete
    ActiveSheet.ShowAllData
    
    'Select Team 2
    
Sheets("Team Performance").Select
        Range("$A$1:$Y$1500").AutoFilter Field:=15, Criteria1:= _
        "Team 2"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    
    'Create and save the image section!!!!
    
    'Create temporary chart as canvas
    Set sht = Selection.Worksheet
    Selection.Copy
    sht.Pictures.Paste.Select
    Set sh = sht.Shapes(sht.Shapes.Count)
    Set tmpChart = Charts.Add
    tmpChart.ChartArea.Clear
    tmpChart.Name = "PicChart" & (Rnd() * 10000)
    Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
    tmpChart.ChartArea.Width = sh.Width
    tmpChart.ChartArea.Height = sh.Height
    tmpChart.Parent.Border.LineStyle = 0
    'Paste range as image to chart
    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste
    'Save chart image to file
    fileSaveName = "C:\Users\tabbytomo\Desktop\Team2.jpg"
      tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
    'Clean up
    sht.Cells(1, 1).Activate
    sht.ChartObjects(sht.ChartObjects.Count).Delete
    sh.Delete
    ActiveSheet.ShowAllData

 

[RoryA]

Untested, but hopefully this gives you the idea:

Option Explicit

Const SAVE_FOLDER As String = "C:\Users\tabbytomo\Desktop\"
Const SAVE_FORMAT As String = "jpg"
Sub SelectTeams()
    
    Dim team, TeamList
    
    TeamList = Array("Team 1", "Team 2") ' add to this as needed
    
    
    For Each team In TeamList
    
        MakeTeamSnapshot team
    
    Next team

End Sub
Sub MakeTeamSnapshot(team As Variant)
    Dim PerformanceSheet As Worksheet
    Set PerformanceSheet = Sheets("Team Performance")
    
    With PerformanceSheet
        .Range("$A$1:$Y$1500").AutoFilter Field:=15, Criteria1:=team
        Dim tmpChart As Chart
        Set tmpChart = Charts.Add
        tmpChart.ChartArea.Clear
        tmpChart.Name = "PicChart" & (Rnd() * 10000)
        Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=.Name)
        With tmpChart
            With .ChartArea
                .Width = .Parent.Width
                .Height = .Parent.Height
            End With
            .Parent.Border.LineStyle = 0
        End With
    'Paste range as image to chart
        .Range("A1").CurrentRegion.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        tmpChart.ChartArea.Select
        tmpChart.Paste
        'Save chart image to file
        Dim fileSaveName As Variant
        fileSaveName = SAVE_FOLDER & Replace$(team, " ", "") & "." & SAVE_FORMAT
          tmpChart.Export Filename:=fileSaveName, FilterName:=SAVE_FORMAT
        'Clean up
        tmpChart.Parent.Delete
        .ShowAllData
    End With

End Sub

 

[tabbytomo]

Untested, but hopefully this gives you the idea:

Option Explicit

Const SAVE_FOLDER As String = "C:\Users\tabbytomo\Desktop\"
Const SAVE_FORMAT As String = "jpg"
Sub SelectTeams()
  
    Dim team, TeamList
  
    TeamList = Array("Team 1", "Team 2") ' add to this as needed
  
  
    For Each team In TeamList
  
        MakeTeamSnapshot team
  
    Next team

End Sub
Sub MakeTeamSnapshot(team As Variant)
    Dim PerformanceSheet As Worksheet
    Set PerformanceSheet = Sheets("Team Performance")
  
    With PerformanceSheet
        .Range("$A$1:$Y$1500").AutoFilter Field:=15, Criteria1:=team
        Dim tmpChart As Chart
        Set tmpChart = Charts.Add
        tmpChart.ChartArea.Clear
        tmpChart.Name = "PicChart" & (Rnd() * 10000)
        Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=.Name)
        With tmpChart
            With .ChartArea
                [COLOR=rgb(250, 197, 28)].Width = .Parent.Width[/COLOR]
                .Height = .Parent.Height
            End With
            .Parent.Border.LineStyle = 0
        End With
    'Paste range as image to chart
        .Range("A1").CurrentRegion.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        tmpChart.ChartArea.Select
        tmpChart.Paste
        'Save chart image to file
        Dim fileSaveName As Variant
        fileSaveName = SAVE_FOLDER & Replace$(team, " ", "") & "." & SAVE_FORMAT
          tmpChart.Export Filename:=fileSaveName, FilterName:=SAVE_FORMAT
        'Clean up
        tmpChart.Parent.Delete
        .ShowAllData
    End With

End Sub

Thank you for taking a look, definitely a strong start, a bit of tweaking to the chart code and it should be sorted! Thank you!!