使用VBA为折线图添加年度分段功能

问题描述 #

我需要为表格中每一行的州级月度时间序列数据生成图表，要求图表按年份（2018-2023）拆分为多个系列。已经单独用一行提取了每个日期列对应的年份，但现有代码无法实现按年份拆分系列，也没法正确设置坐标轴格式。作为VBA新手，求修正方案。

尝试的代码 #

Sub CreateGraphsForRow()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rngData As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim rowIndex As Long
    Dim seriesRange As Range
    Dim cht As ChartObject
    
    ' Set the workbook and worksheet where your data is located
    Set wb = Workbooks("State_30@3_Trends.xlsx") ' Change the workbook name as needed
    Set ws = wb.Worksheets("UNS 30@3") ' Change the worksheet name as needed
    
    ' Define the range of your data
    With ws
        lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        lastCol = .Cells(149, .Columns.Count).End(xlToLeft).Column
        Set rngData = .Range("G149", .Cells(lastRow, lastCol))
    End With
    
    ' Loop through each row in the data range
    For rowIndex = 1 To rngData.Rows.Count
        ' Create a new chart object on the worksheet
        Set cht = ws.ChartObjects.Add(Left:=10, Width:=375, Top:=75 + (rowIndex - 1) * 250, Height:=225)
        
        ' Define the range for the graph's data series
        Set seriesRange = rngData.Rows(rowIndex)
        
        ' Set the chart's data source to the defined range
        cht.Chart.SetSourceData Source:=seriesRange
        
        ' Set the chart type to Line
        cht.Chart.ChartType = xlLine
        
        ' Set other optional properties of the chart, such as chart title, axis labels, etc.
        cht.Chart.HasTitle = True
        cht.Chart.ChartTitle.Text = "Graph Title"
        ' Customize other properties as needed
        
    Next rowIndex
End Sub

修正后的代码 #

Sub CreateYearSplitGraphs()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim rowIndex As Long, colIndex As Long
    Dim cht As ChartObject
    Dim yearRow As Long ' 存储年份所在行的行号，根据你的表格调整
    Dim currentYear As String
    
    ' 绑定目标工作簿和工作表
    Set wb = Workbooks("State_30@3_Trends.xlsx")
    Set ws = wb.Worksheets("UNS 30@3")
    
    ' ********** 请根据你的表格结构修改以下参数 **********
    yearRow = 148 ' 假设年份数据在第148行，替换成你实际的年份行号
    Dim labelRow As Long: labelRow = 147 ' 假设月度日期标签在第147行，替换成实际行号
    ' **************************************************
    
    With ws
        lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row ' 获取G列最后一行数据行号
        lastCol = .Cells(yearRow, .Columns.Count).End(xlToLeft).Column ' 获取年份行最后一列列号
    End With
    
    ' 遍历每一行州数据（从第149行开始，对应你的原始数据起始行）
    For rowIndex = 149 To lastRow
        ' 创建图表，设置位置和尺寸，逐行向下排列
        Set cht = ws.ChartObjects.Add(Left:=10, Width:=600, Top:=75 + (rowIndex - 149) * 300, Height:=250)
        
        With cht.Chart
            .ChartType = xlLine ' 设置为折线图
            .HasTitle = True
            ' 用G列的州名作为图表标题
            .ChartTitle.Text = ws.Cells(rowIndex, "G").Value & " 月度趋势（按年份拆分）"
            
            ' 设置坐标轴标题
            .Axes(xlCategory).HasTitle = True
            .Axes(xlCategory).AxisTitle.Text = "月份"
            .Axes(xlValue).HasTitle = True
            .Axes(xlValue).AxisTitle.Text = "数值"
            
            ' 清除默认生成的系列，避免干扰
            Do While .SeriesCollection.Count > 0
                .SeriesCollection(1).Delete
            Loop
            
            ' 按年份遍历列，拆分并添加系列
            currentYear = ""
            For colIndex = 7 To lastCol ' G列对应第7列，从这里开始遍历数据列
                ' 当遇到新年份时，创建新系列
                If ws.Cells(yearRow, colIndex).Value <> currentYear Then
                    currentYear = ws.Cells(yearRow, colIndex).Value
                    .SeriesCollection.NewSeries
                    .SeriesCollection(.SeriesCollection.Count).Name = currentYear
                    ' 初始化当前系列的X/Y值数组
                    Dim xVals() As Variant, yVals() As Variant
                    ReDim xVals(0 To 0)
                    ReDim yVals(0 To 0)
                    xVals(0) = ws.Cells(labelRow, colIndex).Value
                    yVals(0) = ws.Cells(rowIndex, colIndex).Value
                Else
                    ' 同一年份的列，追加数据到当前系列的数组
                    ReDim Preserve xVals(0 To UBound(xVals) + 1)
                    ReDim Preserve yVals(0 To UBound(yVals) + 1)
                    xVals(UBound(xVals)) = ws.Cells(labelRow, colIndex).Value
                    yVals(UBound(yVals)) = ws.Cells(rowIndex, colIndex).Value
                End If
                ' 更新当前系列的数据源
                .SeriesCollection(.SeriesCollection.Count).XValues = xVals
                .SeriesCollection(.SeriesCollection.Count).Values = yVals
            Next colIndex
            
            ' 设置坐标轴格式，优化显示
            With .Axes(xlCategory)
                .TickLabels.Orientation = 45 ' 标签倾斜45度，避免重叠
                .MajorTickMark = xlTickMarkNone ' 隐藏主刻度线
            End With
            With .Axes(xlValue)
                .MinimumScale = 0 ' Y轴起始值，可根据数据调整
                .MajorUnit = 10 ' Y轴刻度间隔，可根据数据调整
            End With
            
            ' 添加图例并设置位置
            .HasLegend = True
            .Legend.Position = xlLegendPositionBottom
        End With
    Next rowIndex
End Sub

使用说明 #

• 参数调整：代码中标注**********的部分，需要你根据自己的表格结构修改yearRow（年份所在行）和labelRow（月度日期标签所在行）
• 图表布局：Top:=75 + (rowIndex - 149) * 300控制图表的垂直间距，可修改300调整间距大小；Width和Height可调整图表尺寸
• 坐标轴优化：Y轴的MinimumScale和MajorUnit可根据你的数据范围修改，确保图表显示合理
• 系列拆分逻辑：代码会自动识别年份列的变化，每遇到新年份就创建一个新的折线系列，同一年份的月度数据会归到同一个系列下

内容的提问来源于stack exchange，提问作者Abdullah Khan