VBA计数器按日期周数分类统计功能开发求助

我现有一段VBA代码，用于读取指定列的值，验证行内值组合是否符合定义规则并计数。现在需要新增按周统计的功能：
Sheet2的G列存储着dd/mm/yyyy格式的日期，要求根据日期对应的周数，将符合值组合条件的行的计数结果，写入Sheet15对应周数的行中。

举个例子：

• 有5行数据，其中2行符合值组合（1,2,3,3/2/0 和 1,2,3,3/1/0），它们的日期（28/09/2023、29/09/2023）属于同一周，这部分计数为2，要显示在Sheet15的第39行；
• 另外1行符合值组合（1,2,3,3/1/0），日期05/06/2023对应另一周，计数为1，要显示在Sheet15的第23行。

我尝试了以下代码，但无法实现日期周数相关的处理：

Sub Button1_Click() 'Leaks
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim searchRange As Range
    Dim countRange As Range
    Dim count As Long
    Dim searchValue1 As String
    Dim searchValue2 As String
    Dim searchValue3 As String
    Dim searchValue4 As Variant ' Change the data type to Variant
    
    ' Define the search range in Sheet2 where you want to look for the data combination
    Set searchRange = Sheet2.Range("B1:H" & Sheet2.Cells(Rows.count, "H").End(xlUp).row) ' Modify the range as per your data
    
    ' Define the range in Sheet15 where you want to store the count
    Set countRange = Sheet15.Range("P1") ' Modify the cell as per your preference
    
    ' Clear previous count
    countRange.value = ""
    
    ' Define the search values (combination of data)
    searchValue1 = "1"
    searchValue2 = "2"
    searchValue3 = "3"
    searchValue4 = Array("3/1/0", "3/2/0") ' Modify the values as per your requirement
    
    ' Convert the search range to a variant array for faster processing
    Dim dataArr As Variant
    dataArr = searchRange.value
    
    ' Loop through the array to search for the combination of values
    Dim i As Long
    Dim numRows As Long
    Dim foundCount As Long
    
    numRows = UBound(dataArr, 1)
    
    For i = 1 To numRows
        ' Check if each search value is found in the row
        If dataArr(i, 1) = searchValue1 And _
           dataArr(i, 2) = searchValue2 And _
           dataArr(i, 3) = searchValue3 And _
           IsValueInArray(dataArr(i, 7), searchValue4) Then ' Use a helper function to check if value is in array
            foundCount = foundCount + 1
        End If
    Next i
    
    ' Store the count in the count range of Sheet15
    countRange.value = foundCount
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Private Function IsValueInArray(value As Variant, arr As Variant) As Boolean
    ' Helper function to check if value is in array
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If value = arr(i) Then
            IsValueInArray = True
            Exit Function
        End If
    Next i
    IsValueInArray = False
End Function

修改后的完整代码 #

Sub Button1_Click() 'Leaks
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim searchRange As Range
    Dim wsData As Worksheet, wsResult As Worksheet
    Dim searchValue1 As String, searchValue2 As String, searchValue3 As String
    Dim searchValue4 As Variant
    Dim dataArr As Variant
    Dim i As Long, numRows As Long
    Dim weekNum As Integer
    ' 用字典存储各周的计数
    Dim weekCounts As Object
    Set weekCounts = CreateObject("Scripting.Dictionary")
    
    ' 定义工作表，避免硬编码Sheet名称
    Set wsData = ThisWorkbook.Sheets("Sheet2")
    Set wsResult = ThisWorkbook.Sheets("Sheet15")
    
    ' 定义数据范围（B到H列，从第1行到最后一行有数据的行）
    Set searchRange = wsData.Range("B1:H" & wsData.Cells(wsData.Rows.Count, "H").End(xlUp).Row)
    
    ' 清空Sheet15中P列的历史计数（可根据实际需求调整列）
    wsResult.Range("P:P").ClearContents
    
    ' 定义要匹配的值组合
    searchValue1 = "1"
    searchValue2 = "2"
    searchValue3 = "3"
    searchValue4 = Array("3/1/0", "3/2/0")
    
    ' 把数据读入数组提升效率
    dataArr = searchRange.Value
    
    numRows = UBound(dataArr, 1)
    
    ' 遍历数据行
    For i = 1 To numRows
        ' 检查当前行是否符合值组合条件
        If dataArr(i, 1) = searchValue1 And _
           dataArr(i, 2) = searchValue2 And _
           dataArr(i, 3) = searchValue3 And _
           IsValueInArray(dataArr(i, 7), searchValue4) Then
            
            ' 处理日期：把G列的dd/mm/yyyy文本转成日期格式
            Dim cellDate As Date
            cellDate = DateSerial( _
                Right(dataArr(i, 6), 4), _
                Mid(dataArr(i, 6), 4, 2), _
                Left(dataArr(i, 6), 2) _
            )
            
            ' 获取周数：默认周日为一周起始，若要周一为起始可加参数2，即WeekNum(cellDate, 2)
            weekNum = WorksheetFunction.WeekNum(cellDate)
            
            ' 更新字典中的计数
            If weekCounts.Exists(weekNum) Then
                weekCounts(weekNum) = weekCounts(weekNum) + 1
            Else
                weekCounts(weekNum) = 1
            End If
        End If
    Next i
    
    ' 将字典中的计数写入Sheet15对应行的P列
    ' 示例逻辑：假设Sheet15的A列存储周数，找到对应行后写入；若为固定行映射周数，可替换为Select Case逻辑
    Dim key As Variant
    For Each key In weekCounts.Keys
        Dim matchRow As Range
        Set matchRow = wsResult.Range("A:A").Find(What:=key, LookIn:=xlValues, LookAt:=xlWhole)
        If Not matchRow Is Nothing Then
            wsResult.Cells(matchRow.Row, "P").Value = weekCounts(key)
        End If
    Next key
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Private Function IsValueInArray(value As Variant, arr As Variant) As Boolean
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If value = arr(i) Then
            IsValueInArray = True
            Exit Function
        End If
    Next i
    IsValueInArray = False
End Function

关键改动说明 #

• 新增字典存储周数计数：用Scripting.Dictionary高效记录每个周数对应的符合条件行数，避免重复遍历；
• 日期格式转换：将Sheet2 G列的文本日期转成标准Date类型，确保周数计算准确；
• 周数计算：使用WorksheetFunction.WeekNum获取周数，可通过参数调整一周的起始日（默认周日，参数2对应周一）；
• 结果写入逻辑：支持两种映射方式——按Sheet15 A列的周数匹配行，或替换为固定行号映射（比如用Select Case weekNum指定周数对应行）；
• 清空历史数据：每次运行前清空目标列旧数据，避免残留干扰。

内容的提问来源于stack exchange，提问作者Gonçalo