Search code examples
excelvba

how to make a stacked histogram macro VBA

I want to create an excel macro stacked histogram from a table (4 columns)

Column Z ( identifier )

Column AA (error name)

Column AB (frequency)

AC column (color)

I want the X AXIS sound diagram to take the Values ​​from column Z the identifiers, and the Y axis column AB the frequency and the bars each by its color (which is in column AC) and with a legend which displays each color linked to what error name

Here is my table:

result table

Here is the code I started with:

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

This is what it shows me

resulat diagram

I was not able to display each bar by its color and the legend it does not group the error names

Please, do you know a way to do this simply and automatically for all the bars of the histogram at once?

Thanks in advance

YRI

Solution
    • Merge cells on the first col before creating the chart.
    • Change the color of Points() instead of 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

    enter image description here

    • If you're looking for stacked column chart, pivot chart might be a good approach.
    • The customized color isn't being applied to the chart due to inconsistency in the color scheme within the source table. For instance, ERREUR1 has different setting on row 2 & 3.
    Sub ColumnStacked()
    Dim rCell As Range, rngData As Range, blankRng As Range
    Dim oSht1 As Worksheet, oSht2 As Worksheet
    Set oSht1 = Sheets("Sheet1")
    oSht1.Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set oSht2 = ActiveSheet
    Set rngData = oSht2.Range("Z1").CurrentRegion
    With rngData
        On Error Resume Next
        Set blankRng = .Columns(1).SpecialCells(xlCellTypeBlanks)
        On Error Resume Next
        If Not blankRng Is Nothing Then blankRng.FormulaR1C1 = "=R[-1]C"
    End With
    Dim oPC As PivotCache, oPT As PivotTable
    Set oPC = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData, Version:=8)
    Set rCell = rngData.Cells(1).Offset(, rngData.Columns.Count + 2)
    Set oPT = oPC.CreatePivotTable(TableDestination:=rCell, DefaultVersion:=8)
    With oPT
        .PivotFields("IDF").Orientation = xlRowField
        .PivotFields("Raison").Orientation = xlColumnField
        .AddDataField .PivotFields("Fréquence"), "Sum of F", xlSum
    End With
    oSht2.Shapes.AddChart2(297, xlColumnStacked).Select
    ActiveChart.SetSourceData Source:=oPT.TableRange1
    ActiveChart.SetElement (msoElementLegendRight)
End Sub

    enter image description here