Excel VBA 如何遍历非固定起始、长度不一的多表格批量生成饼图

核心识别逻辑 #

你现有代码的核心局限是硬编码了第一张表的起始行位置，现在可以利用「所有业务表格的表头行统一为红色背景」这个固定特征，自动完成全表的表格定位、有效数据行遍历，不需要手动指定每个表格的起始/结束行：

• 先提取第一张表已知红色表头的背景色值，作为所有合法表头的判断基准
• 逐行扫描工作表，碰到符合基准色值的行就判定为一张新表的表头行
• 从表头行的下一行开始，直到碰到下一个表头行/连续空行/工作表末尾，就是当前表格的所有有效数据行
• 全局累计图表的纵向位置偏移，逐行生成饼图，避免图表重叠

替换后的完整可运行代码 #

Sub GeneratePieChartsForAllTables()
    Dim ws As Worksheet
    Dim rownumber As Long
    Dim lastSheetRow As Long
    Dim headerColor As Long
    Dim currentTableStartRow As Long
    Dim currentTableEndRow As Long
    Dim LabelRange As Range
    Dim ValueRange As Range
    Dim Chart As ChartObject
    Dim LeftIndent As Long
    Dim TopIndent As Long
    
    ' 初始化固定参数
    Set ws = ThisWorkbook.Worksheets("Testplan Überblick")
    LeftIndent = 726
    TopIndent = 60
    lastSheetRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 提取已知第一张表的表头红色作为判断基准（第一张表的表头固定在第5行）
    headerColor = ws.Cells(5, 1).Interior.Color
    
    ' 固定绑定所有表格共用的标签范围（和你原来的逻辑一致，用表头行的标签）
    Set LabelRange = Union(ws.Cells(5, 3), ws.Cells(5, 5), ws.Cells(5, 7), ws.Cells(5, 9))
    
    ' 清除工作表上已有的旧图表，避免重复生成
    ws.ChartObjects.Delete
    
    ' 逐行扫描全表找所有红色表头
    For rownumber = 1 To lastSheetRow
        ' 判定当前行是合法表头
        If ws.Cells(rownumber, 1).Interior.Color = headerColor Then
            ' 当前表的数据起始行是表头下一行
            currentTableStartRow = rownumber + 1
            ' 顺着往下找当前表的结束行：直到碰到下一个红色表头/碰到A列空值
            currentTableEndRow = currentTableStartRow
            Do While currentTableEndRow <= lastSheetRow
                ' 碰到下一个表头就停止
                If ws.Cells(currentTableEndRow, 1).Interior.Color = headerColor Then
                    currentTableEndRow = currentTableEndRow - 1
                    Exit Do
                End If
                ' 碰到A列空值就停止
                If IsEmpty(ws.Cells(currentTableEndRow, 1).Value) Then
                    currentTableEndRow = currentTableEndRow - 1
                    Exit Do
                End If
                currentTableEndRow = currentTableEndRow + 1
            Loop
            ' 防止整个表扫完没碰到结束条件
            If currentTableEndRow > lastSheetRow Then currentTableEndRow = lastSheetRow
            
            ' 遍历当前表格的所有有效数据行，逐行生成饼图
            Dim dataRow As Long
            For dataRow = currentTableStartRow To currentTableEndRow
                ' 绑定当前行的数值范围
                Set ValueRange = Union(ws.Cells(dataRow, 3), ws.Cells(dataRow, 5), ws.Cells(dataRow, 7), ws.Cells(dataRow, 9))
                ' 新增图表
                Set Chart = ws.ChartObjects.Add(Left:=LeftIndent, Width:=270, Top:=TopIndent, Height:=210)
                With Chart
                    .Chart.SetSourceData Source:=ValueRange
                    .Chart.ChartType = xlPie
                    .Chart.HasTitle = True
                    .Chart.SetElement (msoElementChartTitleAboveChart)
                    .Chart.ChartTitle.Text = ws.Cells(dataRow, 1).Value
                    .Chart.FullSeriesCollection(1).XValues = LabelRange
                    .Name = ws.Cells(dataRow, 1).Value
                End With
                ' 累计纵向偏移，下一个图表往下排
                TopIndent = TopIndent + 225
            Next dataRow
            
            ' 把rownumber直接跳到当前表结束行，避免重复扫描
            rownumber = currentTableEndRow
        End If
    Next rownumber
    
    MsgBox "所有饼图生成完成，共生成 " & ws.ChartObjects.Count & " 个图表"
End Sub

注意事项 #

• 代码默认标签范围和第一张表完全一致，也就是所有表格的C/E/G/I列对应的标签都是固定的，和你现有业务逻辑匹配；如果后续不同表格的标签有差异，可以把LabelRange的绑定逻辑改成“当前扫描到的表头行对应的C/E/G/I列单元格”即可
• 如果你的表格之间没有空行，或者空行间隔在2行以内，只需要把判断空行的逻辑改成“连续2行A列为空才判定为表格结束”，就不会把表格中间的空行误判为表尾
• 代码默认生成新图表前会清除全表旧图表，如果需要保留历史图表，可以把ws.ChartObjects.Delete这行删掉
• 你原有代码存在ValueRange未跟随循环行更新的bug，修改后的代码在逐行遍历的时候会实时绑定当前行的数值范围，不会出现所有图表都引用同一行数据的问题

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