使用VBA移除重复图例项：兼容次Y轴及效率优化需求

问题背景 #

现有一段VBA代码用于移除Excel图表中的重复图例项，但该代码仅在图表无次Y轴数据系列时有效——当存在次Y轴时，SeriesCollection集合与LegendEntries的顺序会出现不一致。需要修改代码以兼容次Y轴场景，同时希望了解是否仅通过LegendEntries即可实现更高效的处理方式。

原代码 #

主过程代码

Sub legend_tartup()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim Cht As Chart
Dim CurrentSheet As Worksheet
Dim lgnd As Legend
Dim uniqueEntries As New Collection
Dim LgdID As New Collection
Dim No2ndAxis As Integer
Dim i As Long
Dim Series_Count As Integer
Dim LeftPos As Integer
Dim TopPos As Integer


  Application.ScreenUpdating = False
  Application.EnableEvents = False

For Each Cht In ActiveWorkbook.Charts

    No2ndAxis = 0
    
    If Cht.HasLegend = True Then
        LeftPos = Cht.Legend.Left
        TopPos = Cht.Legend.Top
    Else
        LeftPos = Empty
        TopPos = Empty
    End If
    
    Cht.HasLegend = False
    
    ' Add a new legend with desired settings
    Cht.HasLegend = True
    Set lgnd = Cht.Legend
    With lgnd
        .IncludeInLayout = False
        .Border.LineStyle = xlContinuous
        .Border.ColorIndex = 1  ' Black
        .Interior.ColorIndex = 2  ' White
        If LeftPos = Empty Then
            .Position = xlLegendPositionCorner
        Else
            .Left = LeftPos
            .Top = TopPos
        End If
    End With
    

    Series_Count = Cht.SeriesCollection.Count
    

'Find uniquie legends and there order number
    For i = 1 To Series_Count
    'Debug.Print Cht.SeriesCollection(i).Name
    'Debug.Print lgnd.LegendEntries(i).Parent
        If CollectionValueExists(uniqueEntries, Cht.SeriesCollection(i).Name) = False Then
            uniqueEntries.Add Cht.SeriesCollection(i).Name
            LgdID.Add i
        End If
    Next i
' delete legends that are repeated
    For i = Series_Count To 1 Step -1
        If CollectionValueExists(LgdID, i) = False Then
            lgnd.LegendEntries(i).Delete
        End If
    Next i
    
    
Set uniqueEntries = Nothing
Set LgdID = Nothing

Next Cht

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

辅助函数代码

Public Function CollectionValueExists(ByRef target As Collection, value As Variant) As Boolean
        Dim index As Long
        For index = 1 To target.Count
            If target(index) = value Then
                CollectionValueExists = True
                Exit For
            End If
        Next index
    End Function

解决方案 #

1. 兼容次Y轴的修改方案 #

问题核心是次Y轴存在时，LegendEntries的顺序为主Y轴系列在前，次Y轴系列在后，而SeriesCollection的顺序是系列添加的顺序，两者不匹配。因此不能直接用Series的索引对应LegendEntries的索引，需要通过系列名称关联对应的图例项。

修改后的代码：

Sub RemoveDuplicateLegends_WithSecondaryAxis()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim Cht As Chart
    Dim lgnd As Legend
    Dim uniqueNames As New Collection
    Dim i As Long
    Dim leftPos As Double, topPos As Double
    
    For Each Cht In ActiveWorkbook.Charts
        ' 保存原图例位置
        If Cht.HasLegend Then
            leftPos = Cht.Legend.Left
            topPos = Cht.Legend.Top
        Else
            leftPos = Empty
            topPos = Empty
        End If
        
        ' 重建图例（确保格式正确）
        Cht.HasLegend = False
        Cht.HasLegend = True
        Set lgnd = Cht.Legend
        With lgnd
            .IncludeInLayout = False
            .Border.LineStyle = xlContinuous
            .Border.ColorIndex = 1
            .Interior.ColorIndex = 2
            If Not IsEmpty(leftPos) Then
                .Left = leftPos
                .Top = topPos
            Else
                .Position = xlLegendPositionCorner
            End If
        End With
        
        ' 收集唯一图例名称（保留首次出现的）
        On Error Resume Next ' 忽略重复添加的错误
        For i = 1 To lgnd.LegendEntries.Count
            uniqueNames.Add lgnd.LegendEntries(i).Text, Key:=UCase(lgnd.LegendEntries(i).Text)
        Next i
        On Error GoTo 0
        
        ' 删除重复图例项（从后往前删，避免索引混乱）
        For i = lgnd.LegendEntries.Count To 1 Step -1
            Dim entryText As String
            entryText = UCase(lgnd.LegendEntries(i).Text)
            ' 检查当前名称是否是首次出现的位置
            Dim isFirstOccurrence As Boolean
            isFirstOccurrence = (uniqueNames(entryText) = i)
            If Not isFirstOccurrence Then
                lgnd.LegendEntries(i).Delete
            End If
        Next i
        
        ' 清空集合
        Set uniqueNames = Nothing
    Next Cht
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

2. 仅通过LegendEntries的高效实现方式 #

上面的修改已直接基于LegendEntries处理，无需依赖SeriesCollection，彻底解决次Y轴顺序问题。另外可使用Dictionary替代Collection提升查找效率（Dictionary的Key查找为O(1)，远快于Collection的O(n)遍历）：

Sub RemoveDuplicateLegends_Efficient()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim Cht As Chart
    Dim lgnd As Legend
    Dim uniqueDict As Object ' Scripting.Dictionary
    Dim i As Long
    Dim leftPos As Double, topPos As Double
    
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    For Each Cht In ActiveWorkbook.Charts
        ' 保存原图例位置
        If Cht.HasLegend Then
            leftPos = Cht.Legend.Left
            topPos = Cht.Legend.Top
        Else
            leftPos = Empty
            topPos = Empty
        End If
        
        ' 重建图例
        Cht.HasLegend = False
        Cht.HasLegend = True
        Set lgnd = Cht.Legend
        With lgnd
            .IncludeInLayout = False
            .Border.LineStyle = xlContinuous
            .Border.ColorIndex = 1
            .Interior.ColorIndex = 2
            If Not IsEmpty(leftPos) Then
                .Left = leftPos
                .Top = topPos
            Else
                .Position = xlLegendPositionCorner
            End If
        End With
        
        ' 记录每个名称的首次出现索引
        uniqueDict.RemoveAll
        For i = 1 To lgnd.LegendEntries.Count
            Dim entryText As String
            entryText = UCase(lgnd.LegendEntries(i).Text)
            If Not uniqueDict.Exists(entryText) Then
                uniqueDict.Add entryText, i
            End If
        Next i
        
        ' 删除重复项
        For i = lgnd.LegendEntries.Count To 1 Step -1
            entryText = UCase(lgnd.LegendEntries(i).Text)
            If uniqueDict(entryText) <> i Then
                lgnd.LegendEntries(i).Delete
            End If
        Next i
    Next Cht
    
    Set uniqueDict = Nothing
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

关键说明 #

• 直接操作LegendEntries，完全脱离SeriesCollection依赖，彻底解决次Y轴顺序不一致问题。
• 使用Scripting.Dictionary替代Collection，大幅提升重复项查找效率，图例项越多效果越明显。
• 从后往前删除图例项，避免删除后索引移位导致的遍历错误。

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