For Loop构建图表

Question

我有以下数据集：

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

最难的部分 - 站点（A 列）将会更改。有几个月我可能有最多位置 10。我需要代码足够动态以便为每个独特的站点创建图表。正如您将在代码中看到的，我正在创建一个新工作簿，在旧文件中创建图表，然后 cut/paste 到新工作簿的一个选项卡中。然后我根据图表标题重命名作品sheet。然后我需要代码循环回到开头并为 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:$C,Sheet1!$E:$I")
        
        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")
        Set Srs2 = ActiveChart.SeriesCollection(2)
        Srs2.Name = ActiveSheet.Range("$F")
        Set Srs3 = ActiveChart.SeriesCollection(3)
        Srs3.Name = ActiveSheet.Range("$G")
        Set Srs4 = ActiveChart.SeriesCollection(4)
        Srs4.Name = ActiveSheet.Range("$H")
        Set Srs5 = ActiveChart.SeriesCollection(5)
        Srs5.Name = ActiveSheet.Range("$I")
    
    '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

For Loop构建图表

For Loop to build charts

excel

vba

loops

for-loop

linechart