Excel VBA 遍历工作簿折线图调整数据标签显示规则及位置

Sub OptimizeLineChartLabels()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim chtObj As ChartObject
    Dim cht As Chart
    Dim ser As Series
    Dim ptCount As Long
    Dim pts As Long
    
    ' 处理当前工作簿，如需处理其他打开的工作簿可修改为对应工作簿对象
    Set wb = ThisWorkbook
    
    ' 遍历工作簿内所有工作表
    For Each ws In wb.Worksheets
        ' 遍历当前工作表内的所有图表
        For Each chtObj In ws.ChartObjects
            Set cht = chtObj.Chart
            ' 仅对折线图执行规则
            If cht.ChartType = xlLine Then
                Set ser = cht.SeriesCollection(1)
                ptCount = ser.Points.Count
                
                ' 先初始化所有数据点显示标签
                For pts = 1 To ptCount
                    ser.Points(pts).HasDataLabel = True
                Next pts
                
                ' 按规则筛选保留标签
                For pts = 1 To ptCount
                    ' 保留首尾、每4个中的第一个（间隔3个保留1个）
                    If pts <> 1 And pts <> ptCount And pts Mod 4 <> 1 Then
                        ser.Points(pts).DataLabel.Delete
                    Else
                        ' 保留的标签设置为略高于折线的位置
                        ser.Points(pts).DataLabel.Position = xlLabelPositionAbove
                    End If
                Next pts
            End If
        Next chtObj
    Next ws
    
    ' 释放对象内存
    Set ser = Nothing
    Set cht = Nothing
    Set chtObj = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

• 全工作簿图表遍历：新增双层循环，外层遍历所有工作表，内层遍历工作表内所有图表，无需手动指定图表名称，自动识别所有折线图执行标签优化规则
• 标签位置设置：对保留下来的有效数据标签，通过Position = xlLabelPositionAbove参数统一设置为折线上方，符合阅读习惯
• 逻辑优化：将原有的计数判断改为更稳定的模运算判断，避免循环内手动修改迭代变量导致的逻辑异常，同时优化对象引用结构，减少冗余代码提升执行效率

• 代码默认仅处理每个折线图的第一个数据系列，如需处理同一图表内的所有系列，可新增一层遍历SeriesCollection集合的循环即可
• 如需调整标签保留的间隔，只需修改模运算的数值即可，比如需要每5个保留1个，将pts Mod 4 <> 1改为pts Mod 5 <> 1即可

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