☰

Excel - （柱形）图 - 根据实际值对数据系列进行 Z 索引

tag-icon • tag-icon microsoft-excel microsoft-excel-2013 charts
Excel - （柱形）图 - 根据实际值对数据系列进行 Z 索引

我有一个包含多个数据系列的柱形图。例如：

示例数据

默认柱形图

我不想让列彼此相邻，所以我设置了减少Series overlap和Gap widthFormat Data Series...

我得到了什么

现在系列一个在另一个之上。但是它们的 Z 索引（Z 位置）由图表中的系列顺序定义，因此当最后一个系列具有最高值时，其列将超出不可见的其他系列。

能否以某种方式根据列的实际值对它们进行排序？我想将最小值放在最前面。就像在这张图片中一样（这里使用了古老的 mspaint-fu :)）。

我想要得到什么
（//已编辑 - 第一个版本被错误地绘制）

附言：我需要它来处理非常大的数据系列（看起来像直方图），所以我绝对不想把这些列放在一起。但它可以被“过滤”到低系列视图，使用其他图表类型可能会导致显示这些离散值的失真。

感谢您的建议！

答案1

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

在此处输入图片描述

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

然后我们需要一个处理表，如J:R列所示。

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

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

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

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

在此处输入图片描述

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

答案2

我创建了宏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

相关内容