Question

目的： 根据电子表格中的数据动态生成（100％堆积）图形。

条件： 我有一个重复里程碑的列表网站（每个网站使用相同的4个里程碑，但项目之间的里程碑不同。此功能将用于几个项目的跟踪器）。

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

数据设置： 列X3及更高版本列出了里程碑。有40条记录（2个空白行），有4个唯一值。 d1字典包含输出到列R中的唯一4个值（仅用于测试）。

Image: List of data and location/milestones

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

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键而不是手动命名？（参见＆lt; ===箭头）。

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

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

使用词典键

0 个答案: