Excel - （柱形）图表 - 数据系列的 Z-index 根据实际值

一种方法是创建一个处理表来计算系列的升序。

列 E:G 使用公式计算出第一个最小的、第二个最小的等等SMALL()，其中第一个参数是您的值行，第二个参数是排名 - 所以单元格 E3 是=SMALL($A3:$C3,1)、 F3=SMALL($A3:$C3,2)和 G3 =SMALL($A3:$C3,3)。复制尽可能多的行，如果超过 3 个系列，则根据需要添加尽可能多的列。

然后我们需要一个处理表，显示在 J:R 列中。

每个系列都有一个列，每个可能的位置都按升序排列。在“第 1”列组中，在 J 列中，我们可以使用公式检查 A 系列是否是第一个最小系列

`=IF(E3=A3,A3,0)`

如果存在匹配，则显示该系列的值。如果不是，则显示零。

现在，如果您使用范围 J2:R6 创建簇状柱形图并应用 100% 系列重叠，您会发现需要重新排序列。使用“选择数据”对话框重新排列列，使 3C 位于顶部，1A 位于底部。

最后，更改每个系列的颜色。所有 A 系列必须为蓝色，所有 B 系列必须为橙色，C 均为灰色（或任何您的实际颜色）。

我为Andi Mohr 的解决方案自动化创建了宏。也许有人觉得它有用。

特点/限制：

• 适用于垂直柱形图
• 为所需的所有部分系列创建带有列的“帮助”表。
• 期望列中的数据系列
• 禁用项目系列（在“选择数据源”中）可能会破坏宏！
• “帮助”表可以移动到另一张表
• 保持与原始表的交互性
• 列颜色（填充）从源图表复制

用法

1. 将代码复制到 VBA 模块中
2. 选择源表
3. 运行宏

动图

代码

Option Explicit

Public Sub Chart_ZIndexAdjusted()
    Dim SourceChart As Chart
    Set SourceChart = ActiveChart
    
    If SourceChart Is Nothing Then
        Call MsgBox("No chart selected." & vbNewLine & "(Do not select chart Axis!)", vbOKOnly + vbExclamation, "Error")
        Exit Sub
    End If
    
    'Check Chart type
    Select Case SourceChart.ChartType
    Case xlColumnClustered 'comma separated values
        Debug.Print "ChartType OK"
    Case Else
        Call MsgBox("ChartType: " & CStr(SourceChart.ChartType) & " is not supported." & vbNewLine & vbNewLine & "More about ChartTypes: https://docs.microsoft.com/en-us/office/vba/api/excel.xlcharttype", vbOKOnly + vbExclamation, "Error")
        Exit Sub
    End Select
    
    Dim SeriesCol As SeriesCollection
    Set SeriesCol = SourceChart.SeriesCollection 'All series from the chart
    
    Dim ValRng() As Range
    ReDim ValRng(1 To SeriesCol.Count) 'Range arrays for each series
    
    Dim NameRng() As Range
    ReDim NameRng(1 To SeriesCol.Count) 'Range with name for each series
    
    Dim CategoriesVal As String 'Value specifying categories
    
    Dim SeriesCount As Long
    SeriesCount = SeriesCol.Count
    
    'Ranges addresses could be retrieved for each series from its Formula property
    Dim i As Long
    For i = 1 To SeriesCount
        Dim FormulaParts() As String
        FormulaParts = Split(SeriesCol(i).Formula, ",")

        Set NameRng(i) = Range(Mid(FormulaParts(0), Len("=SERIES(") + 1, Len(FormulaParts(0)) - Len("=SERIES(")))
        Set ValRng(i) = Range(FormulaParts(2))
        If i = 1 Then
                CategoriesVal = FormulaParts(1)
        End If
    Next i
    
    'Check if all data are in one "table" and sheet
    Dim ValuesStartRow As Long
    Dim ValuesLength As Long
    Dim Sheet As Worksheet
    ValuesStartRow = ValRng(1).Cells.Item(1).Row
    ValuesLength = ValRng(1).Cells.Rows.Count
    Set Sheet = ValRng(1).Parent
    For i = 2 To SeriesCol.Count
        If Not ((ValuesStartRow = ValRng(i).Cells.Item(1).Row) _
                And (ValuesLength = ValRng(i).Cells.Rows.Count) _
                And (Sheet Is ValRng(i).Parent)) _
        Then
            Call MsgBox("Chart values are not on same sheet or lines or series does not have same length", vbOKOnly + vbExclamation, "Error")
            Exit Sub
        End If
    Next i
    
    Dim NTName As String 'Name for a new table for chart
    NTName = SourceChart.Name & "_InputData"
    
    'Look for old table and remove it
    With Sheet.ListObjects
        For i = 1 To .Count
            If .Item(i).Name = NTName Then
                .Item(i).Delete
            End If
        Next i
    End With
    
    'check if there is space for table headers
    If ValuesStartRow < 2 Then
        Call MsgBox("No space for a new table headers" & vbNewLine & "(Add a row on top of the sheet and try it again.)", vbOKOnly + vbExclamation, "Error")
    End If
    
    Dim NTRange As Range 'New Table Range
    Set NTRange = Sheet.Cells(ValuesStartRow - 1, Sheet.UsedRange.Columns.Count + 3) 'Placed two cells right from most right cell in the sheet
    
    Dim NTCols As Long
    NTCols = SeriesCount * SeriesCount 'Count of columns needed is series count ^2
    
    Set NTRange = NTRange.Resize(ValuesLength, NTCols)
    'NTRange.Select
 
    Dim NT As ListObject 'A new table for a new chart
    Set NT = Sheet.ListObjects.Add(xlSrcRange, NTRange)
    NT.Name = SourceChart.Name & "_InputData"
    NT.Range.Select 'Select a new table (it scrolls to its position)
    
    'Populate a new table headers
    Dim j As Long
    With NT.HeaderRowRange.Cells
        For i = 1 To SeriesCount
            For j = 1 To SeriesCount
                .Item((i - 1) * SeriesCount + j).Value2 = NameRng(j).Value2 & CStr(i)
            Next j
        Next i
    End With
    
    'Populate New Table with
    With NT.ListColumns
        For i = 1 To SeriesCount 'i is Z-index of column of the New Table
            Dim AllValsArray As String 'Array of addresses of all first series values
            AllValsArray = ValRng(1).Item(1).Address(False, False) 'The initial (1st) value (without delimiter)
            For j = 2 To SeriesCount
                AllValsArray = AllValsArray & "," & ValRng(j).Item(1).Address(False, False) 'delimiter + added value
            Next j
            
            Dim FormulaText As String
            For j = 1 To SeriesCount
                Dim ValueCellAddr As String 'Address of first cell with series values
                ValueCellAddr = ValRng(j).Item(1).Address(False, False)
                'Set text of formula
                FormulaText = "=IF(RANK.EQ(" & ValueCellAddr & ",(" & AllValsArray & "),0)=" & i & "," & ValueCellAddr & ",0)"
                'Insert formula to the first cell of the column
                .Item((i - 1) * SeriesCount + j).DataBodyRange.Formula = FormulaText
            Next j
        Next i
    End With
    
    Dim ChObj As ChartObject 'Chartobject for selected chart
    For Each ChObj In Sheet.ChartObjects
        If ChObj.Chart Is SourceChart Then
            Exit For
        End If
    Next ChObj
    
    Dim NTChName As String 'Name for a new chart
    NTChName = ChObj.Name & "_ZindexAdjusted"
    
    'Find and delete existing Z-index Adjusted chart
    With Sheet.ChartObjects
        For i = 1 To .Count
            If .Item(i).Name = NTChName Then
                Call .Item(i).Delete
            End If
        Next i
    End With

    Dim NTChObj As Object 'Must be Object Type! See: https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.chartobjects#return-value
    Set NTChObj = ChObj.Duplicate 'Create copy of the chart
    NTChObj.Name = NTChName 'Rename a new chart
    
    Dim FillColor() As Long
    ReDim FillColor(1 To SeriesCount)
    Dim LineColor() As Long
    ReDim LineColor(1 To SeriesCount)
    
    With SourceChart.SeriesCollection
        For i = 1 To SeriesCount
            'Saves color from the original chart
            FillColor(i) = SourceChart.SeriesCollection.Item(i).Format.Fill.ForeColor.RGB
            'LineColor(i) = SourceChart.SeriesCollection.Item(i).Format.Line.Forecolor.RGB
        Next i
    End With

    'Remove all series in copied chart
    With NTChObj.Chart.SeriesCollection
        For i = 1 To .Count
            .Item(1).Delete 'Item(1) because collection is re-numbered during loop
        Next i
        
        'Create a new series from the new table
        For i = 1 To NTCols
            Call .Add(NT.ListColumns.Item(i).Range, xlColumns, True, False) 'Add a new series
            With .Item(.Count).Format 'the last added series
                'Set series colors (only the fill acc. to orginal chart)
                .Fill.ForeColor.RGB = FillColor(i - (Fix((i - 1) / SeriesCount) * SeriesCount)) 'fix = trunc
                '.Line.Forecolor.RGB = FillColor(i - (Fix((i - 1) / SeriesCount) * SeriesCount))
            End With
        Next i
    End With
    
    'Set copy catergories labels
    If Len(CategoriesVal) > 0 Then
        NTChObj.Chart.FullSeriesCollection(1).XValues = "=" & CategoriesVal
    End If
    
'Lines bellow could be uncommented if you want features described in comments
'============================================================================

'    'Delete the original chart (not recommended)
'    Call ChObj.Delete

'    'Place the new chart over the original (original will be hidden under)
'    NTChObj.Left = ChObj.Left
'    NTChObj.Top = ChObj.Top

End Sub