VBA计算日期范围内各年度占比代码无输出问题排查

输入当月起止日期，计算2010至2023年各年度在该日期范围内的占比，但运行以下VBA宏代码时无输出，问题出在哪里？

Sub CalculatePercentageByYear()

    ' Define variables for start date, end date, and percentage by year
    Dim startDate As Date
    Dim endDate As Date
    Dim percentageByYear() As Double
    
    ' Get the start date and end date from cells DTH1 and DTI1
    startDate = Range("DTH1").Value
    endDate = Range("DTI1").Value
    
    ' Get the date range corresponding data values
    Dim dateRange As Range
    Dim dataRange As Range
    Dim dateCell As Range
    Dim dataCell As Range
    Dim yr As Integer
    Dim cellsInRange As Double
    Dim i As Integer
    
    Set dateRange = Range("B1:DTG1")
    Set dataRange = Range("B2:DTG28")
    
    ' Calculate the total number of cells in the data range
    Dim totalCells As Double
    totalCells = dataRange.Cells.Count
    
    ReDim percentageByYear(1 To 1, 1 To 14)
    
    For i = 1 To 14
        ' Get the date cell and data cell for the current year
        Set dateCell = dateRange.Cells(i)
        Set dataCell = dataRange.Cells(i)
        
        ' Get the year from the current date cell
        yr = Year(dateCell.Value)
        
        ' Check if any non-empty cells are present in the data range
        If Application.WorksheetFunction.CountA(dataRange.Columns(i)) > 0 Then
            ' Calculate the percentage of difference between end date data value and start date data value
            Dim startDateDataValue As Variant
            Dim endDateDataValue As Variant
            On Error Resume Next
            startDateDataValue = dataRange.Cells(Application.Match(startDate, dateRange, 0), i)
            endDateDataValue = dataRange.Cells(Application.Match(endDate, dateRange, 0), i)
            On Error GoTo 0
            If IsError(startDateDataValue) Or IsError(endDateDataValue) Then
                percentageByYear(1, i) = "N/A"
            ElseIf startDateDataValue = 0 And endDateDataValue = 0 Then
                percentageByYear(1, i) = 0
            ElseIf startDateDataValue = 0 Then
                percentageByYear(1, i) = -1
            Else
                percentageByYear(1, i) = ((endDateDataValue - startDateDataValue) / startDateDataValue)
            End If
        Else
            percentageByYear(1, i) = 0 ' Set percentage as 0 if no non-empty cells are found
        End If
    Next i
    
    ' Output the percentage by year row-wise to cells DTH2 and below
    Range("DTH2").Resize(1, 14).Value = percentageByYear
    
    ' Add table and set table style
    Dim tbl As ListObject
    On Error Resume Next
    Set tbl = ActiveSheet.ListObjects("Table1")
    On Error GoTo 0
    If Not tbl Is Nothing Then
        tbl.Delete
    End If
    
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Range("DTH2:DTZ28"))
    tbl.Name = "Table1"
    tbl.TableStyle = "TableStyleMedium16"
    
    ' Set the table headers to the corresponding years
    For i = 1 To 14
        tbl.ListColumns(i).Name = "Year " & 2010 + i - 1
    Next i
    
End Sub

核心问题分析 #

• 数组类型不匹配：percentageByYear被定义为Double类型数组，但代码中尝试给它赋值字符串"N/A"，触发类型不匹配错误。由于On Error Resume Next的存在，错误被掩盖，数组元素无法正确赋值，最终输出为空。

• Match函数逻辑错误：Application.Match(startDate, dateRange, 0)返回的是dateRange中匹配到的列号，但代码中把它作为dataRange.Cells(行号, 列号)的第一个参数（行号），完全不符合数据结构逻辑，导致无法正确获取对应日期的数据值。

• 日期与数据的对应逻辑混乱：代码循环14列对应2010-2023年，但dateRange是整行的日期范围，仅取第i个单元格的年份却未将Match操作限定在该年份的日期范围内，无法定位到对应年份的起止日期数据。

• 输出与表格范围不匹配：代码仅输出1行数据，但创建表格时使用了DTH2:DTZ28这个包含大量空行的范围，不仅无意义，还可能导致表格显示异常。

• 错误处理滥用：On Error Resume Next掩盖了Match查找失败、类型不匹配等多种错误，使得问题难以排查，无法及时发现逻辑漏洞。

修正后的代码示例 #

Sub CalculatePercentageByYear()
    Dim startDate As Date, endDate As Date
    Dim percentageByYear() As Variant ' 改为Variant数组，支持数值和"N/A"字符串
    Dim i As Integer, targetYear As Integer
    Dim targetStartDate As Date, targetEndDate As Date
    Dim startCol As Variant, endCol As Variant
    Dim startVal As Double, endVal As Double
    
    ' 获取输入的起止日期
    startDate = Range("DTH1").Value
    endDate = Range("DTI1").Value
    
    ' 初始化结果数组（1行14列，对应2010-2023）
    ReDim percentageByYear(1 To 1, 1 To 14)
    
    For i = 1 To 14
        targetYear = 2010 + i - 1
        ' 构造当年的起止日期（复用输入的月日）
        targetStartDate = DateSerial(targetYear, Month(startDate), Day(startDate))
        targetEndDate = DateSerial(targetYear, Month(endDate), Day(endDate))
        
        ' 在日期行（B1:DTG1）中查找当年起止日期的列号
        startCol = Application.Match(targetStartDate, Range("B1:DTG1"), 0)
        endCol = Application.Match(targetEndDate, Range("B1:DTG1"), 0)
        
        On Error Resume Next
        ' 获取对应列的第二行数据（假设第二行是目标数据行）
        startVal = Range("B2:DTG2").Cells(startCol).Value
        endVal = Range("B2:DTG2").Cells(endCol).Value
        On Error GoTo 0
        
        ' 处理各种异常情况
        If IsError(startCol) Or IsError(endCol) Or IsError(startVal) Or IsError(endVal) Then
            percentageByYear(1, i) = "N/A"
        ElseIf startVal = 0 And endVal = 0 Then
            percentageByYear(1, i) = 0
        ElseIf startVal = 0 Then
            percentageByYear(1, i) = -1
        Else
            percentageByYear(1, i) = (endVal - startVal) / startVal
        End If
    Next i
    
    ' 输出计算结果
    Range("DTH2").Resize(1, 14).Value = percentageByYear
    
    ' 创建表格（仅包含有数据的范围）
    Dim tbl As ListObject
    On Error Resume Next
    Set tbl = ActiveSheet.ListObjects("Table1")
    On Error GoTo 0
    If Not tbl Is Nothing Then tbl.Delete
    
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Range("DTH2:DTZ2"))
    tbl.Name = "Table1"
    tbl.TableStyle = "TableStyleMedium16"
    
    ' 设置表头
    For i = 1 To 14
        tbl.ListColumns(i).Name = "Year " & (2010 + i - 1)
    Next i
End Sub

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