如何制作堆叠直方图宏VBA

Question

我想从表格（4 列）创建一个 Excel 宏堆叠直方图

Z 列（标识符）

AA 列（错误名称）

AB 列（频率）

AC柱（彩色）

我希望 X 轴声音图从 Z 列标识符中获取值，Y 轴 AB 列中的频率和条形各按其颜色（位于 AC 列中）并带有显示每种颜色的图例链接到什么错误名称

这是我的桌子：

这是我开始的代码：

Set plageDiagrammeT = FeuilleName.Range("Z1:AC" & lastRowIDF)

' Créer le diagramme
Set diagramme = FeuilleName.ChartObjects.Add(Left:=400, Width:=675, Top:=0, Height:=225)
' Configurez le type de graphique
diagramme.Chart.ChartType = xlColumnClustered ' Vous pouvez ajuster le type de graphique si nécessaire

' Définir le type de graphique
With diagramme.Chart
.SetSourceData Source:=plageDiagrammeT, PlotBy:=xlColumns
.ChartType = xlColumnStacked
.HasTitle = True
.ChartTitle.Text = "Titre du Diagramme"
.SeriesCollection(1).XValues = FeuilleName.Range("Z2:Z" & lastRowIDF) ' Axe des X
.SetSourceData Source:=FeuilleName.Range("AB2:AB" & lastRowIDF)
.FullSeriesCollection(1).XValues = FeuilleName.Range("Z2:Z" & lastRowIDF) ' Légende
.Axes(xlCategory).TickLabelPosition = xlTickLabelPositionNextToAxis ' Position des étiquettes sur l'axe des X
' Ajouter les valeurs de la colonne AA comme légende
With FeuilleName
For i = 2 To lastRowIDF
If Not IsEmpty(.Cells(i, 27).Value) And Not IsEmpty(.Cells(i, 29).Value) Then
diagramme.Chart.SeriesCollection.NewSeries
diagramme.Chart.FullSeriesCollection(i).Name = .Cells(i, 27).Value ' Colonne AA + AC

End If
Next i

End With

End With
' Personnalisez les couleurs des barres
i = 0
For i = 2 To lastRowIDF
Dim colorCode As Long
RGBColor = FeuilleName.Cells(i, 29).Value ' Colonne AC (valeur RGB)
RGBValues = Split(Mid(RGBColor, 5, Len(RGBColor) - 5), ",")
redValue = Trim(RGBValues(0))
greenValue = Trim(RGBValues(1))
blueValue = Trim(RGBValues(2))
diagramme.Chart.SeriesCollection(1).Format.Fill.ForeColor.RGB = RGB(redValue, greenValue, blueValue)
Next i

' Affichez le graphique
diagramme.Activate

这就是它向我展示的

我无法按颜色和图例显示每个条，它不会对错误名称进行分组

请问，您知道一种方法可以简单且自动地同时对直方图的所有条形执行此操作吗？

提前致谢

YRI

Answer 1

• 创建图表之前合并第一列上的单元格。
• 更改

  Points()

  的颜色而不是

  SeriesCollection

Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey As String, vRng, sIDF As String
    Dim arrData
    Dim oSht1 As Worksheet, oSht2 As Worksheet
    const COL="Z"  ' modify as needed
    Set oSht1 = Sheets("Sheet1")  ' modify as needed
    oSht1.Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set oSht2 = ActiveSheet
    Set objDic = CreateObject("scripting.dictionary")
    Set rngData = oSht2.Range(COL & "1").CurrentRegion
    arrData = rngData.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        sKey = arrData(i, 1)
        If sKey = "" Then
            sKey = sIDF
        Else
            sIDF = sKey
        End If
        If objDic.exists(sKey) Then
            Set objDic(sKey) = Union(oSht2.Cells(i, COL), objDic(sKey))
        Else
            Set objDic(sKey) = oSht2.Cells(i, COL)
        End If
    Next i
    For Each vRng In objDic.Items
        '        Debug.Print vRng.Address
        If vRng.Cells.Count > 1 Then vRng.Merge
    Next
    oSht2.Shapes.AddChart2(201, xlColumnClustered).Select
    ActiveChart.SetSourceData Source:=rngData.Resize(, rngData.Columns.Count - 1)
    ActiveChart.ClearToMatchStyle
    ActiveChart.ChartStyle = 207
    Dim RGBColor, RGBValues, redValue, greenValue, blueValue
    For i = LBound(arrData) + 1 To UBound(arrData)
        Dim colorCode As Long
        RGBColor = arrData(i, 4)
        RGBValues = Split(Mid(RGBColor, 5, Len(RGBColor) - 5), ",")
        redValue = Trim(RGBValues(0))
        greenValue = Trim(RGBValues(1))
        blueValue = Trim(RGBValues(2))
        ActiveChart.FullSeriesCollection(1).Points(i - 1).Format.Fill.ForeColor.RGB = RGB(redValue, greenValue, blueValue)
    Next i
    Set objDic = Nothing
End Sub