使用字典键在excel VBA中设置graphics系列

目标：根据电子表格中的数据dynamic生成（100％堆积）graphics。

条件：我有一个包含重复里程碑的列表站点（每个站点使用相同的4个里程碑，但项目之间的里程碑不同，这个function将在多个项目的跟踪器中使用）。

当前状态：它正在根据需要绘制堆叠条形图，但我似乎无法将图例（系列）重命名为正在从已识别的里程碑构build的字典中的唯一键。

数据设置：列X3及以后有里程碑列表。 有40个logging（2个空白行）和4个唯一值。 d1字典包含输出到列R中的唯一4个值（仅用于testing）。

图像：数据和位置/里程碑列表

与绘制图表有关的所有代码：

With Worksheets("Sheet1") .Columns.EntireColumn.Hidden = False 'Unhide all columns. .Rows.EntireRow.Hidden = False 'Unhide all rows. .AutoFilterMode = False lastrow = Range("W" & Rows.Count).End(xlUp).Row 'If MsgBox("Lastrow is: " & lastrow, vbYesNo) = vbNo Then Exit Sub End With Dim MyLocationCount As Integer Dim MyMilestoneCount As Integer 'Use VbA code to find the unique values in the array with locations. 'GET ARRAY OF UNIQUE LOCATIONS Worksheets("Sheet1").Range("W3:W" & lastrow).Select Dim d As Object, c As Range, k, tmp As String Set d = CreateObject("scripting.dictionary") For Each c In Selection tmp = Trim(c.Value) If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1 Next c For Each k In d.Keys Debug.Print k, d(k) MyLocationCount = MyLocationCount + 1 Next k Range("U1:U" & d.Count) = Application.Transpose(d.Keys) '<-- For verification of the locations keys only. 'MsgBox (MyLocationCount) 'SET ARRAY CATEGORY VALUES Dim d3 As Object Set d3 = CreateObject("scripting.dictionary") x = 0 Do x = x + 1 d3.Add key:=x, Item:=1 'MsgBox "Key " & x & ": " & d3(x) & " Key Count: " & d3.Count Loop Until x = MyLocationCount Dim k3 As Variant For Each k3 In d3.Keys ' Print key and value Debug.Print k3, d3(k3) Next '------------ Range("T1:T" & d3.Count) = Application.Transpose(d3.Items)'<-- For verification of the locations items only. 'GET ARRAY OF UNIQUE MILESTONES Worksheets("Sheet1").Range("X3:X" & lastrow).Select Dim d1 As Object, c1 As Range, k1, tmp1 As String Set d1 = CreateObject("scripting.dictionary") For Each c1 In Selection tmp1 = Trim(c1.Value) If Len(tmp1) > 0 Then d1(tmp1) = d1(tmp1) + 1 Next c1 For Each k1 In d1.Keys Debug.Print k1, d1(k1) MyMilestoneCount = MyMilestoneCount + 1 Next k1 Range("R1:R" & d1.Count) = Application.Transpose(d1.Keys) '<-- For verification of the milestone keys only. ActiveSheet.ChartObjects("Chart 2").Activate 'Delete all current series of data. Dim n As Long With ActiveChart For n = .SeriesCollection.Count To 1 Step -1 .SeriesCollection(n).Delete Next n End With '==== START PROBLEM AREA ===== 'Loop the XValues and Values code as many times as you have series. make sure to increment the collection counter. Use array values to hardcode the categories. x = 0 Do Until x = MyMilestoneCount With ActiveChart.SeriesCollection.NewSeries .XValues = Array(d.Keys) .Values = Array(d3.Items) x = x + 1 End With 'NAME MILESTONE 'MsgBox (d1.keys(x)) ActiveChart.FullSeriesCollection(x).Name = "=""Milestone " & x & """" '<==== THIS WORKS BUT IS NOT DESIRED. 'ActiveChart.FullSeriesCollection(x).Name = d1.Keys(x) '<==== THIS IS WHAT IM TRYING TO GET TO WORK. Loop '==== END PROBLEM AREA ===== ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1" 'SET LEGEND SIZE ActiveChart.Legend.Select Selection.Left = 284.71 Selection.Width = 69.289 Selection.Height = 144.331 Selection.Top = 9.834 Selection.Height = 157.331 With ActiveSheet.ChartObjects("Chart 2").Chart.Axes(xlValue, xlPrimary) '.Border.LineStyle = xlNone .MajorTickMark = xlNone .MinorTickMark = xlNone .TickLabelPosition = xlNone End With End Sub 

任何人有任何想法如何使用d1键，而不是手动命名？ （请参阅<===箭头）。

我有关于如何根据电子表格中确定的数据对条形图的每个部分进行着色的代码（请参阅图像）。 现在我的主要挑战是要正确命名系列。

谢谢你，祝你有美好的一天！ Okki