使用日期时下标超出范围错误

Question

我正在尝试创建一个堆积柱形图（与我上一个问题中的相同）。 我现在在尝试将日期变量设置为电子表格中的日期时遇到下标超出范围错误。

这是发生错误的 for 循环的开始：

For b = 2 To 255

    DDate = ThisWorkbook("Query Results.xlsm").Worksheets("Macros Test Sheet").Cells(b, 3).Value

DDate 是带有此错误突出显示的行。 本质上，我的 C 列有一堆格式为 m/dd/yyyy 的日期。 我创建了一个 for 循环来遍历 C 列中的每一行，并且基本上将 DDate 变量设置为该日期。 然后，我有 if 语句可以根据月份提取某些信息。 我在上面的行中将 DDate 声明为日期。 这是我的代码，所以你可以看到我在说什么（大部分都是重复的）。

Sub SecondaryInterimTracker()

    Dim DDate As Date
    Dim MonthNum As Integer
    
    Dim human As String
    human = "Human"
    Dim method As String
    method = "Method/Procedure"
    Dim equipment As String
    equipment = "Equipment"
    Dim material As String
    material = "Material"
    Dim environment As String
    environment = "Environment"
    
    Dim JanHuman As Single
    Dim JanMethod As Single
    Dim JanEquipment As Single
    Dim JanMaterial As Single
    Dim JanEnvironment As Single
    Dim JanUnknown As Single
    
    JanHuman = 0
    JanMethod = 0
    JanEquipment = 0
    JanMaterial = 0
    JanEnvironment = 0
    JanUnknown = 0
    
    Dim FebHuman As Single
    Dim FebMethod As Single
    Dim FebEquipment As Single
    Dim FebMaterial As Single
    Dim FebEnvironment As Single
    Dim FebUnknown As Single
    
    FebHuman = 0
    FebMethod = 0
    FebEquipment = 0
    FebMaterial = 0
    FebEnvironment = 0
    FebUnknown = 0
    
    Dim MarHuman As Single
    Dim MarMethod As Single
    Dim MarEquipment As Single
    Dim MarMaterial As Single
    Dim MarEnvironment As Single
    Dim MarUnknown As Single
    
    MarHuman = 0
    MarMethod = 0
    MarEquipment = 0
    MarMaterial = 0
    MarEnvironment = 0
    MarUnknown = 0
    
    Dim AprHuman As Single
    Dim AprMethod As Single
    Dim AprEquipment As Single
    Dim AprMaterial As Single
    Dim AprEnvironment As Single
    Dim AprUnknown As Single
    
    AprHuman = 0
    AprMethod = 0
    AprEquipment = 0
    AprMaterial = 0
    AprEnvironment = 0
    AprUnknown = 0
    
    Dim MayHuman As Single
    Dim MayMethod As Single
    Dim MayEquipment As Single
    Dim MayMaterial As Single
    Dim MayEnvironment As Single
    Dim MayUnknown As Single
    
    MayHuman = 0
    MayMethod = 0
    MayEquipment = 0
    MayMaterial = 0
    MayEnvironment = 0
    MayUnknown = 0
    
    Dim JunHuman As Single
    Dim JunMethod As Single
    Dim JunEquipment As Single
    Dim JunMaterial As Single
    Dim JunEnvironment As Single
    Dim JunUnknown As Single
    
    JunHuman = 0
    JunMethod = 0
    JunEquipment = 0
    JunMaterial = 0
    JunEnvironment = 0
    JunUnknown = 0
    
    Dim JulHuman As Single
    Dim JulMethod As Single
    Dim JulEquipment As Single
    Dim JulMaterial As Single
    Dim JulEnvironment As Single
    Dim JulUnknown As Single
    
    JulHuman = 0
    JulMethod = 0
    JulEquipment = 0
    JulMaterial = 0
    JulEnvironment = 0
    JulUnknown = 0
    
    Dim AugHuman As Single
    Dim AugMethod As Single
    Dim AugEquipment As Single
    Dim AugMaterial As Single
    Dim AugEnvironment As Single
    Dim AugUnknown As Single
    
    AugHuman = 0
    AugMethod = 0
    AugEquipment = 0
    AugMaterial = 0
    AugEnvironment = 0
    AugUnknown = 0
    
    Dim SepHuman As Single
    Dim SepMethod As Single
    Dim SepEquipment As Single
    Dim SepMaterial As Single
    Dim SepEnvironment As Single
    Dim SepUnknown As Single
    
    SepHuman = 0
    SepMethod = 0
    SepEquipment = 0
    SepMaterial = 0
    SepEnvironment = 0
    SepUnknown = 0
    
    Dim OctHuman As Single
    Dim OctMethod As Single
    Dim OctEquipment As Single
    Dim OctMaterial As Single
    Dim OctEnvironment As Single
    Dim OctUnknown As Single
    
    OctHuman = 0
    OctMethod = 0
    OctEquipment = 0
    OctMaterial = 0
    OctEnvironment = 0
    OctUnknown = 0
    
    Dim NovHuman As Single
    Dim NovMethod As Single
    Dim NovEquipment As Single
    Dim NovMaterial As Single
    Dim NovEnvironment As Single
    Dim NovUnknown As Single
    
    NovHuman = 0
    NovMethod = 0
    NovEquipment = 0
    NovMaterial = 0
    NovEnvironment = 0
    NovUnknown = 0
    
    Dim DecHuman As Single
    Dim DecMethod As Single
    Dim DecEquipment As Single
    Dim DecMaterial As Single
    Dim DecEnvironment As Single
    Dim DecUnknown As Single
    
    DecHuman = 0
    DecMethod = 0
    DecEquipment = 0
    DecMaterial = 0
    DecEnvironment = 0
    DecUnknown = 0
    
    For b = 2 To 255
    
        DDate = Workbooks("Query Results.xlsm").Worksheets("Macros Test Sheet").Cells(b, 3).Value
        MonthNum = Month(DDate)
        If MonthNum = 1 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                JanHuman = JanHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                JanMethod = JanMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                JanEquipment = JanEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                JanMaterial = JanMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                JanEnvironment = JanEnvironment + 1
            Else
                JanUnknown = JanUnknown + 1
            End If
        ElseIf MonthNum = 2 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                FebHuman = FebHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                FebMethod = FebMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                FebEquipment = FebEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                FebMaterial = FebMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                FebEnvironment = FebEnvironment + 1
            Else
                FebUnknown = FebUnknown + 1
            End If
        ElseIf MonthNum = 3 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                MarHuman = MarHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                MarMethod = MarMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                MarEquipment = MarEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                MarMaterial = MarMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                MarEnvironment = MarEnvironment + 1
            Else
                MarUnknown = MarUnknown + 1
            End If
        ElseIf MonthNum = 4 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                AprHuman = AprHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                AprMethod = AprMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                AprEquipment = AprEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                AprMaterial = AprMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                AprEnvironment = AprEnvironment + 1
            Else
                AprUnknown = AprUnknown + 1
            End If
        ElseIf MonthNum = 5 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                MayHuman = MayHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                MayMethod = MayMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                MayEquipment = MayEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                MayMaterial = MayMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                MayEnvironment = MayEnvironment + 1
            Else
                MayUnknown = MayUnknown + 1
            End If
        ElseIf MonthNum = 6 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                JunHuman = JunHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                JunMethod = JunMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                JunEquipment = JunEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                JunMaterial = JunMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                JunEnvironment = JunEnvironment + 1
            Else
                JunUnknown = JunUnknown + 1
            End If
        ElseIf MonthNum = 7 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                JulHuman = JulHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                JulMethod = JulMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                JulEquipment = JulEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                JulMaterial = JulMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                JulEnvironment = JulEnvironment + 1
            Else
                JulUnknown = JulUnknown + 1
            End If
        ElseIf MonthNum = 8 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                AugHuman = AugHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                AugMethod = AugMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                AugEquipment = AugEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                AugMaterial = AugMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                AugEnvironment = AugEnvironment + 1
            Else
                AugUnknown = AugUnknown + 1
            End If
        ElseIf MonthNum = 9 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                SepHuman = SepHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                SepMethod = SepMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                SepEquipment = SepEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                SepMaterial = SepMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                SepEnvironment = SepEnvironment + 1
            Else
                SepUnknown = SepUnknown + 1
            End If
        ElseIf MonthNum = 10 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                OctHuman = OctHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                OctMethod = OctMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                OctEquipment = OctEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                OctMaterial = OctMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                OctEnvironment = OctEnvironment + 1
            Else
                OctUnknown = OctUnknown + 1
            End If
        ElseIf MonthNum = 11 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                NovHuman = NovHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                NovMethod = NovMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                NovEquipment = NovEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                NovMaterial = NovMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                NovEnvironment = NovEnvironment + 1
            Else
                NovUnknown = NovUnknown + 1
            End If
        ElseIf MonthNum = 12 Then
            If Worksheets("Macros Test Sheet").Cells(b, 8).Value = human Then
                DecHuman = DecHuman + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = method Then
                DecMethod = DecMethod + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = equipment Then
                DecEquipment = DecEquipment + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = material Then
                DecMaterial = DecMaterial + 1
            ElseIf Worksheets("Macros Test Sheet").Cells(b, 8).Value = environment Then
                DecEnvironment = DecEnvironment + 1
            Else
                DecUnknown = DecUnknown + 1
            End If
        End If
    Next b
    
    Worksheets("Hidden Sheet").Visible = False
    
    Dim january As String
    january = "January"
    Dim february As String
    february = "February"
    Dim march As String
    march = "March"
    Dim april As String
    april = "April"
    Dim may As String
    may = "May"
    Dim june As String
    june = "June"
    Dim july As String
    july = "July"
    Dim august As String
    august = "August"
    Dim september As String
    september = "September"
    Dim october As String
    october = "October"
    Dim november As String
    november = "November"
    Dim december As String
    december = "December"
    Dim x As String
    x = "X"
    Dim y As String
    y = "Human"
    Dim yy As String
    yy = "Method"
    Dim yyy As String
    yyy = "Equipment"
    Dim yyyy As String
    yyyy = "Material"
    Dim yyyyy As String
    yyyyy = "Environment"
    Dim yyyyyy As String
    yyyyyy = "Unknown"
    
    Worksheets("Hidden Sheet").Cells(3, 1).Value = x
    Worksheets("Hidden Sheet").Cells(3, 2).Value = y
    Worksheets("Hidden Sheet").Cells(3, 3).Value = yy
    Worksheets("Hidden Sheet").Cells(3, 4).Value = yyy
    Worksheets("Hidden Sheet").Cells(3, 5).Value = yyyy
    Worksheets("Hidden Sheet").Cells(3, 6).Value = yyyyy
    Worksheets("Hidden Sheet").Cells(3, 7).Value = yyyyyy
    
    Worksheets("Hidden Sheet").Cells(4, 1).Value = january
    Worksheets("Hidden Sheet").Cells(5, 1).Value = february
    Worksheets("Hidden Sheet").Cells(6, 1).Value = march
    Worksheets("Hidden Sheet").Cells(7, 1).Value = april
    Worksheets("Hidden Sheet").Cells(8, 1).Value = may
    Worksheets("Hidden Sheet").Cells(9, 1).Value = june
    Worksheets("Hidden Sheet").Cells(10, 1).Value = july
    Worksheets("Hidden Sheet").Cells(11, 1).Value = august
    Worksheets("Hidden Sheet").Cells(12, 1).Value = september
    Worksheets("Hidden Sheet").Cells(13, 1).Value = october
    Worksheets("Hidden Sheet").Cells(14, 1).Value = november
    Worksheets("Hidden Sheet").Cells(15, 1).Value = december
    
    Worksheets("Hidden Sheet").Cells(4, 2).Value = JanHuman
    Worksheets("Hidden Sheet").Cells(5, 2).Value = FebHuman
    Worksheets("Hidden Sheet").Cells(6, 2).Value = MarHuman
    Worksheets("Hidden Sheet").Cells(7, 2).Value = AprHuman
    Worksheets("Hidden Sheet").Cells(8, 2).Value = MayHuman
    Worksheets("Hidden Sheet").Cells(9, 2).Value = JunHuman
    Worksheets("Hidden Sheet").Cells(10, 2).Value = JulHuman
    Worksheets("Hidden Sheet").Cells(11, 2).Value = AugHuman
    Worksheets("Hidden Sheet").Cells(12, 2).Value = SepHuman
    Worksheets("Hidden Sheet").Cells(13, 2).Value = OctHuman
    Worksheets("Hidden Sheet").Cells(14, 2).Value = NovHuman
    Worksheets("Hidden Sheet").Cells(15, 2).Value = DecHuman
    
    Worksheets("Hidden Sheet").Cells(4, 3).Value = JanMethod
    Worksheets("Hidden Sheet").Cells(5, 3).Value = FebMethod
    Worksheets("Hidden Sheet").Cells(6, 3).Value = MarMethod
    Worksheets("Hidden Sheet").Cells(7, 3).Value = AprMethod
    Worksheets("Hidden Sheet").Cells(8, 3).Value = MayMethod
    Worksheets("Hidden Sheet").Cells(9, 3).Value = JunMethod
    Worksheets("Hidden Sheet").Cells(10, 3).Value = JulMethod
    Worksheets("Hidden Sheet").Cells(11, 3).Value = AugMethod
    Worksheets("Hidden Sheet").Cells(12, 3).Value = SepMethod
    Worksheets("Hidden Sheet").Cells(13, 3).Value = OctMethod
    Worksheets("Hidden Sheet").Cells(14, 3).Value = NovMethod
    Worksheets("Hidden Sheet").Cells(15, 3).Value = DecMethod
    
    Worksheets("Hidden Sheet").Cells(4, 4).Value = JanEquipment
    Worksheets("Hidden Sheet").Cells(5, 4).Value = FebEquipment
    Worksheets("Hidden Sheet").Cells(6, 4).Value = MarEquipment
    Worksheets("Hidden Sheet").Cells(7, 4).Value = AprEquipment
    Worksheets("Hidden Sheet").Cells(8, 4).Value = MayEquipment
    Worksheets("Hidden Sheet").Cells(9, 4).Value = JunEquipment
    Worksheets("Hidden Sheet").Cells(10, 4).Value = JulEquipment
    Worksheets("Hidden Sheet").Cells(11, 4).Value = AugEquipment
    Worksheets("Hidden Sheet").Cells(12, 4).Value = SepEquipment
    Worksheets("Hidden Sheet").Cells(13, 4).Value = OctEquipment
    Worksheets("Hidden Sheet").Cells(14, 4).Value = NovEquipment
    Worksheets("Hidden Sheet").Cells(15, 4).Value = DecEquipment
    
    Worksheets("Hidden Sheet").Cells(4, 5).Value = JanMaterial
    Worksheets("Hidden Sheet").Cells(5, 5).Value = FebMaterial
    Worksheets("Hidden Sheet").Cells(6, 5).Value = MarMaterial
    Worksheets("Hidden Sheet").Cells(7, 5).Value = AprMaterial
    Worksheets("Hidden Sheet").Cells(8, 5).Value = MayMaterial
    Worksheets("Hidden Sheet").Cells(9, 5).Value = JunMaterial
    Worksheets("Hidden Sheet").Cells(10, 5).Value = JulMaterial
    Worksheets("Hidden Sheet").Cells(11, 5).Value = AugMaterial
    Worksheets("Hidden Sheet").Cells(12, 5).Value = SepMaterial
    Worksheets("Hidden Sheet").Cells(13, 5).Value = OctMaterial
    Worksheets("Hidden Sheet").Cells(14, 5).Value = NovMaterial
    Worksheets("Hidden Sheet").Cells(15, 5).Value = DecMaterial
    
    Worksheets("Hidden Sheet").Cells(4, 6).Value = JanEnvironment
    Worksheets("Hidden Sheet").Cells(5, 6).Value = FebEnvironment
    Worksheets("Hidden Sheet").Cells(6, 6).Value = MarEnvironment
    Worksheets("Hidden Sheet").Cells(7, 6).Value = AprEnvironment
    Worksheets("Hidden Sheet").Cells(8, 6).Value = MayEnvironment
    Worksheets("Hidden Sheet").Cells(9, 6).Value = JunEnvironment
    Worksheets("Hidden Sheet").Cells(10, 6).Value = JulEnvironment
    Worksheets("Hidden Sheet").Cells(11, 6).Value = AugEnvironment
    Worksheets("Hidden Sheet").Cells(12, 6).Value = SepEnvironment
    Worksheets("Hidden Sheet").Cells(13, 6).Value = OctEnvironment
    Worksheets("Hidden Sheet").Cells(14, 6).Value = NovEnvironment
    Worksheets("Hidden Sheet").Cells(15, 6).Value = DecEnvironment
    
    Worksheets("Hidden Sheet").Cells(4, 7).Value = JanUnknown
    Worksheets("Hidden Sheet").Cells(5, 7).Value = FebUnknown
    Worksheets("Hidden Sheet").Cells(6, 7).Value = MarUnknown
    Worksheets("Hidden Sheet").Cells(7, 7).Value = AprUnknown
    Worksheets("Hidden Sheet").Cells(8, 7).Value = MayUnknown
    Worksheets("Hidden Sheet").Cells(9, 7).Value = JunUnknown
    Worksheets("Hidden Sheet").Cells(10, 7).Value = JulUnknown
    Worksheets("Hidden Sheet").Cells(11, 7).Value = AugUnknown
    Worksheets("Hidden Sheet").Cells(12, 7).Value = SepUnknown
    Worksheets("Hidden Sheet").Cells(13, 7).Value = OctUnknown
    Worksheets("Hidden Sheet").Cells(14, 7).Value = NovUnknown
    Worksheets("Hidden Sheet").Cells(15, 7).Value = DecUnknown
    
    Dim n As Long 'num of categories
    Dim m As Long 'num of series
    n = 12
    m = 6
    
    Dim r As Range
    Set r = Worksheets("Hidden Sheet").Range("A3")
    Set r = r.Resize(n + 1, m + 1)
    
    Dim s As Shape
    Set s = Worksheets("Macro Test Sheet").Shapes.AddChart2(-1, xlColumnStacked)
    s.Chart.SetSourceData Source:=r
    
End Sub

本质上，我试图计算每个月发生的每种类型的错误（人为、材料等）有多少。 然后，我尝试将这些计数（比如一月份的人为错误）分配给隐藏工作表上的一个单元格。 然后我尝试绘制堆积图。

Answer 1

这是对您的代码应该适用的重构。 为了清楚起见，我试图对其进行评论：

Sub SecondaryInterimTracker()
    
    'Declare variables
    Dim wb As Workbook:         Set wb = ThisWorkbook
    Dim wsData As Worksheet:    Set wsData = wb.Worksheets("Macros Test Sheet")
    Dim wsTable As Worksheet:   Set wsTable = wb.Worksheets("Hidden Sheet")
    Dim rData As Range:         Set rData = wsData.Range("C2:H" & wsData.Cells(wsData.Rows.Count, "C").End(xlUp).Row)
    Dim rTable As Range:        Set rTable = wsTable.Range("A3")
    If rData.Row < 2 Then Exit Sub  'No data
    
    'Load the data into an array
    Dim aData() As Variant:     aData = rData.Value
    
    'Prepare the series headers, and criteria to look for in the data
    Dim aSeries(1 To 6) As Variant
    aSeries(1) = "Human"
    aSeries(2) = "Method/Procedure"
    aSeries(3) = "Equipment"
    aSeries(4) = "Material"
    aSeries(5) = "Environment"
    aSeries(6) = "Unknown"
    
    'Prepare results table
    Dim aResults() As Variant:  ReDim aResults(1 To 13, 1 To UBound(aSeries) + 1)
    Dim lResultRow As Long, lResultCol As Long
    aResults(1, 1) = "X"    'Top left corner of results table
    
    'Populate top-most row of results table with Series names
    lResultCol = 2
    Dim vSeries As Variant
    For Each vSeries In aSeries
        aResults(1, lResultCol) = vSeries
        lResultCol = lResultCol + 1
    Next vSeries
    
    'Populate left-most column of results table with month names
    For lResultRow = 1 To 12
        aResults(lResultRow + 1, 1) = Format(DateSerial(Year(Now), lResultRow, 1), "MMMM")
    Next lResultRow
    
    'Loop through the data
    Dim i As Long, j As Long
    For i = 1 To UBound(aData, 1)
        If IsDate(aData(i, 1)) Then 'Verify we're looking at a date
            lResultRow = Month(aData(i, 1)) + 1 'Row is equal to the month (+1 to get past result table header row)
            
            'Check the Series (Human, Equipment, etc) to get the column
            lResultCol = UBound(aResults, 2)    'Assume other/unknown
            For j = 1 To UBound(aSeries) - 1    '-1 because we don't need to check for Other/Unknown
                If LCase(aData(i, 6)) = LCase(aSeries(j)) Then
                    lResultCol = j + 1  'If match found, set result col (+1 to get past left-most Months column)
                    Exit For
                End If
            Next j
            
            'Add 1 to the appropriate result
            aResults(lResultRow, lResultCol) = aResults(lResultRow, lResultCol) + 1
        End If
    Next i
    
    'Output results
    Set rTable = rTable.Resize(UBound(aResults, 1), UBound(aResults, 2))
    rTable.Value = aResults
    
    'Create chart
    Dim s As Shape
    Set s = wsData.Shapes.AddChart2(-1, xlColumnStacked)
    s.Chart.SetSourceData Source:=rTable
    
End Sub

Answer 2

创建堆积柱形图

Option Explicit

Sub SecondaryInterimTracker()
    
    ' Define constants.
    
    ' Source
    Const sName As String = "Macros Test Sheet"
    Const sfRow As Long = 2
    Const sdCol As String = "C"
    Const scCol As String = "H"
    ' Destination
    Const dName As String = "Hidden Sheet"
    Const dFirstCellAddress As String = "A3"
    Const drCount As Long = 13 ' headers + 12 months
    Const dcCount As Long = 7 ' headers + 5 criteria + 'Unknown'
    Const dFirstHeader As String = "X"
    Const dLastHeader As String = "Unknown"
    ' Both
    Dim Criteria() As Variant: Criteria = VBA.Array( _
        "Human", "Method/Procedure", "Equipment", "Material", "Environment")
    Dim Months() As Variant: Months = VBA.Array( _
        "January", "February", "March", "April", "May", "June", _
        "July", "August", "September", "October", "November", "December")

    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    'Set wb = Workbooks("Query Results.xlsm") ' only if it's not the above
    
    ' Reference the source date and criteria ranges ('sdrg', 'scrg')
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sdCol).End(xlUp).Row
    Dim sdrg As Range
    Set sdrg = sws.Range(sws.Cells(sfRow, sdCol), sws.Cells(slRow, sdCol))
    Dim scrg As Range: Set scrg = sdrg.EntireRow.Columns(scCol)
    
    ' Delete ALL chart objects in the source worksheet. Caution, there is no undo!
    'Dim cho As ChartObject
    'For Each cho In sws.ChartObjects
    '    cho.Delete
    'Next cho
    
    ' Write the values from the source range to the destination array ('dData').
    
    ' Define the destination array.
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' Write column headers.
    
    dData(1, 1) = dFirstHeader
    
    Dim dr As Long
    Dim dc As Long
    
    For dc = 2 To dcCount - 1
        dData(1, dc) = Criteria(dc - 2)
    Next dc
    
    dData(1, dcCount) = dLastHeader
    
    ' Write row headers.
    
    For dr = 2 To drCount
        dData(dr, 1) = Months(dr - 2)
    Next dr
    
    ' Write data.
    
    Dim sdCell As Range
    Dim sdValue As Variant
    Dim sdMonth As Long
    Dim scIndex As Variant
    Dim scString As String
    Dim sr As Long
    
    For Each sdCell In sdrg.Cells
        sr = sr + 1
        sdValue = sdCell.Value
        If IsDate(sdValue) Then ' is a date
            sdMonth = Month(sdValue) + 1 ' row headers
            scString = CStr(scrg.Cells(sr))
            scIndex = Application.Match(scString, Criteria, 0)
            If IsNumeric(scIndex) Then ' match found
                dData(sdMonth, scIndex + 1) = dData(sdMonth, scIndex + 1) + 1
            Else ' no match found; write to the last ('Unknown') column.
                dData(sdMonth, dcCount) = dData(sdMonth, dcCount) + 1
            End If
        ' Else ' not a date; do nothing
        End If
    Next sdCell
    
    ' Write the values from the destination array to the destination range.
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    ' Clear previous data.
    dws.UsedRange.Clear
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    ' Reference the destination range ('drg').
    Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
    ' Write the values from the destination array to the destination range.
    drg.Value = dData
    ' Apply simple formatting.
    drg.EntireColumn.AutoFit ' columns
    drg.Rows(1).Font.Bold = True ' headers
    
    ' Add the chart.
    Dim shp As Shape: Set shp = sws.Shapes.AddChart2(-1, xlColumnStacked)
    shp.Chart.SetSourceData Source:=drg
    
    ' Inform.
    MsgBox "Chart created.", vbInformation
    
End Sub