For Loop 构建图表

Question

我有以下数据集：

我正在尝试编写一个为每个位置构建图表的宏。我已经创建了创建新工作簿、命名工作表的代码，可以为位置 1 创建第一个图表，但我需要代码然后循环返回并对位置 2、位置 3 等执行相同操作。这是一个示例下图：

困难的部分 - 网站（A 列）将发生变化。有几个月我可能有多达 10 个位置。我需要代码足够动态，以便为每个唯一站点创建图表。正如您将在代码中看到的那样，我正在创建一个新工作簿，在旧文件中创建图表，然后剪切/粘贴到新工作簿中的选项卡中。然后我根据图表标题重命名工作表。然后我需要代码循环回到开头，并为 A 列中的每个唯一位置重复该过程。

代码如下：

    Sub ChartBuilder()
    
    Dim Wb As Workbook
        
    Set Wb = ActiveWorkbook
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=Wb.Path & "\Outputs.xlsx"
    ActiveSheet.Name = "Results"
    
    Wb.Activate
    Sheets("Sheet1").Select
      
    '88888 Loop ends below and Loop should come back here
      
    ActiveSheet.Shapes.AddChart2(227, xlLine).Select
    With ActiveChart
    
    'Needs to be dynamic in both Chart Title Name and Data Range
    'Column A is the Location Name - will have duplicates
    'Column C has the weeks.  Weeks are limited to Week 1, Week 2, Week 3, Week 4
    'Column E thru I are the data columns that need to be displayed.
    
        .ChartTitle.Text = ActiveSheet.Range("A2")
        .SetSourceData Source:=Range("Sheet1!$C$2:$C$5,Sheet1!$E$2:$I$5")
        
        ActiveChart.PlotBy = xlColumns  'Chart was flipping and I couldn't figure out why, so wrote code to flip it
        
        Set Srs1 = ActiveChart.SeriesCollection(1)
        Srs1.Name = ActiveSheet.Range("$E$1")
        Set Srs2 = ActiveChart.SeriesCollection(2)
        Srs2.Name = ActiveSheet.Range("$F$1")
        Set Srs3 = ActiveChart.SeriesCollection(3)
        Srs3.Name = ActiveSheet.Range("$G$1")
        Set Srs4 = ActiveChart.SeriesCollection(4)
        Srs4.Name = ActiveSheet.Range("$H$1")
        Set Srs5 = ActiveChart.SeriesCollection(5)
        Srs5.Name = ActiveSheet.Range("$I$1")
    
    'Resizes chart
        With ActiveChart.Parent
             .Height = 300
             .Width = 600
             .Top = 100
             .Left = 100
        End With
    End With
    
    'Copy to new tab, name tab same as Chart Title
    'Loop back to beginning for next filter
    
    Dim OutSht As Worksheet
    Dim Chart As ChartObject
    Dim PlaceInRange As Range
    
    Workbooks("Outputs.xlsx").Activate
    Set OutSht = ActiveWorkbook.Sheets("Results") '<-- Output sheet
    Set PlaceInRange = OutSht.Range("B2:J21")        '<-- Output location
    
        Wb.Activate
        For Each Chart In Sheets("Sheet1").ChartObjects   '<-- Loop charts
            Chart.Cut 'Cut/paste charts
            OutSht.Paste PlaceInRange
        Next Chart
    
    Workbooks("Outputs.xlsx").Activate
    Worksheets("Results").Activate
    ActiveSheet.Name = ActiveChart.ChartTitle.Text
    Sheets.Add.Name = "Results"
    
    '88888 Loop back to beginning
    
    ActiveWorkbook.SaveAs Filename:=Wb.Path & "\" & Format(Now, "yyyymmdd") & " Outputs.xlsx"
    
    Kill Wb.Path & "\Outputs.xlsx"
    
    Wb.Activate
    
    End Sub

Answer 1

以下代码假定每个位置总是有四个星期。我不确定为什么原始代码创建了“Outputs.xlsx”，只是为了随后将其删除为“YYYYMMDDOutputs.xlsx”。我只是直接去了过时的文件名。我还取消了“结果”选项卡，只是将每个图表都做成了自己的选项卡。

四分卫子程序ChartAllLocations:

Public Sub ChartAllLocations()

    Dim location As String, WB As Workbook, ws As Worksheet
    Dim resultsWB As Workbook, data As Range, currLocation As Range
    Dim headers As Range
    
    Set WB = ThisWorkbook
    Set ws = WB.Worksheets("Data")
    Set resultsWB = ResultsWorkbook(WB.path)
    Set headers = ws.Range("E1:I1")

    locIdx = 2
    Do
        Set data = ws.Cells(locIdx, 1).Resize(4, 9)
        ChartBuilder2 resultsWB, data, headers
        locIdx = locIdx + 4
    Loop While ws.Cells(locIdx, 1).Value <> ""
    
    resultsWB.Worksheets("Sheet1").Delete

End Sub

新 Workook 的功能，ResultsWorkbook：

Private Function ResultsWorkbook(path As String) As Workbook

    Dim output As Workbook
    Dim ws As Worksheet
        
    Set output = Workbooks.Add
    output.SaveAs filename:=path & "\" & Format(Now, "yyyymmdd") & " Outputs.xlsx"
        
    Set ResultsWorkbook = output

End Function

构建每个图表的函数ChartBuilder2：

Public Sub ChartBuilder2(WB As Workbook, data As Range, hdrs As Range)

    Dim Chrt As Chart
    
    Set Chrt = WB.Charts.Add(After:=WB.Worksheets(WB.Worksheets.Count))
    Chrt.Name = data.Cells(1, 1)
    Chrt.HasTitle = True
    Chrt.ChartTitle.Text = data.Cells(1, 1)
    Chrt.SetSourceData Source:=data.Cells(1, 5).Resize(4, 5)
    Chrt.ChartType = xlLine
    Chrt.PlotBy = xlColumns
    Chrt.FullSeriesCollection(1).XValues = _
        "={""Week 1"",""Week 2"",""Week 3"",""Week 4""}"
    Chrt.Axes(xlValue).TickLabels.NumberFormat = "0%"
    
    
    For srsIdx = 1 To 5
        Chrt.SeriesCollection(srsIdx).Name = hdrs.Cells(1, srsIdx).Value
    Next srsIdx

End Sub