VBA如何合并两个数组生成适配堆叠柱状图的结构化数据源

堆叠柱状图要求每个分类（本例中为颜色）作为独立系列，同索引的数值对应同一个X轴分组，使用字典分组即可在单次遍历中完成数据整理，比手动双重循环合并数组效率高很多，具体实现步骤如下：

第一步：字典分组处理原始数据 #

用Scripting.Dictionary将同颜色的数值归为一组，自动补0对齐长度，直接得到适配绘图的结构化数据：

' 晚绑定字典，无需提前引用库
Dim colorDict As Object, maxCount As Integer, i As Integer
Set colorDict = CreateObject("Scripting.Dictionary")

' 遍历原始数组分组
For i = LBound(Array1) To UBound(Array1)
    Dim colorKey As String, curVal As Double
    colorKey = Array1(i)
    curVal = Array2(i)
    If Not colorDict.Exists(colorKey) Then
        ' 新颜色新增对应数组
        colorDict.Add colorKey, Array(curVal)
    Else
        Dim tmpArr As Variant
        tmpArr = colorDict(colorKey)
        ReDim Preserve tmpArr(UBound(tmpArr) + 1)
        tmpArr(UBound(tmpArr)) = curVal
        colorDict(colorKey) = tmpArr
    End If
    ' 统计最长数组长度，用于后续补0对齐
    If UBound(colorDict(colorKey)) + 1 > maxCount Then
        maxCount = UBound(colorDict(colorKey)) + 1
    End If
Next

' 所有颜色数组补0到相同长度
Dim key As Variant
For Each key In colorDict.Keys
    Dim arr As Variant
    arr = colorDict(key)
    If UBound(arr) + 1 < maxCount Then
        ReDim Preserve arr(maxCount - 1)
        colorDict(key) = arr
    End If
Next

如果你不需要保留原始Array1和Array2，可以直接在读取记录集时写入字典，省去生成中间数组的步骤，效率更高：

Dim colorDict As Object, maxCount As Integer
Set colorDict = CreateObject("Scripting.Dictionary")

If (dbRecSet.RecordCount <> 0) Then
    Do While Not dbRecSet.EOF
        If dbRecSet.Fields(0).Value <> "" Then
            Dim colorKey As String, curVal As Double
            colorKey = Replace(dbRecSet.Fields(0).Value, " ", Chr(13))
            curVal = dbRecSet.Fields(1).Value
            If Not colorDict.Exists(colorKey) Then
                colorDict.Add colorKey, Array(curVal)
            Else
                Dim tmpArr As Variant
                tmpArr = colorDict(colorKey)
                ReDim Preserve tmpArr(UBound(tmpArr) + 1)
                tmpArr(UBound(tmpArr)) = curVal
                colorDict(colorKey) = tmpArr
            End If
            If UBound(colorDict(colorKey)) + 1 > maxCount Then
                maxCount = UBound(colorDict(colorKey)) + 1
            End If
        End If
        dbRecSet.MoveNext
    Loop
End If

第二步：生成堆叠柱状图 #

每个颜色对应一个系列，遍历字典直接添加即可：

Set cht = output.ChartObjects("Chart 3").Chart
With cht
    .ChartArea.ClearContents
    .ChartType = xl3DColumnStacked
    ' 逐个添加颜色系列
    For Each key In colorDict.Keys
        .SeriesCollection.NewSeries
        .SeriesCollection(.SeriesCollection.Count).Name = key
        .SeriesCollection(.SeriesCollection.Count).Values = colorDict(key)
    Next
    .Axes(xlCategory).TickLabelSpacing = 1
End With

本方案时间复杂度为O(n)，仅需遍历一次原始数据+一次字典遍历，数据量越大效率优势越明显，完全不需要手动合并两个数组。

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