VBA按日期统计就餐时段刷卡及人数(数组字典内置函数去重排序)

• 数据源：

• 分析：1、需要把消费时间列中的字符形式的数据，拆分成日期和时间格式。2、根据拆分的时间格式，用条件语句匹配出就餐早中晚夜时段标签。3、由于数据量大，如果直接用表格公式处理，会卡顿，所以必须借助数组去处理。4、用多条件计数函数去统计，并写入汇总表。
• 效果

点击汇总

• 实现代码

Sub huiz() '汇总
    Dim arr() As Variant
    Dim newarr() As Variant
    Dim lastrow As Long
    Dim lastcol As Long
    Dim Rows As Long
    Dim cols As Long
    Dim i As Long, j As Long, k As Long
    Dim mealType As String
        
    '日期数据处理，拆分
    With ThisWorkbook.Sheets("数据源") ' 最好指定工作表，以防当前活动工作表不是预期的
    
        
        .Columns("L:T").ClearContents
        
    ' 获取最后一行和最后一列
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
        .Cells(1, lastcol + 1) = "日期"
        .Cells(1, lastcol + 2) = "时间"
        .Cells(1, lastcol + 3) = "时段"
    ' 将范围的值读取到数组中
        arr = .Range(.Cells(2, 1), .Cells(lastrow, lastcol)).Value
        
    ' 获取原数组的行数和列数
        Rows = UBound(arr, 1)
        cols = UBound(arr, 2)
        
    ' 定义新的数组，大小比原数组多3列
        ReDim newarr(1 To Rows, 1 To cols + 3)
        
    ' 将原数组的数据复制到新数组中，并在新数组的最后一列添加数据
        For i = 1 To Rows
        ' 复制原数组的数据
            For j = 1 To cols
                newarr(i, j) = arr(i, j)
            Next j
                
        ' 在新数组的最后一列添加数据
            newarr(i, cols + 1) = VBA.DateValue(arr(i, 5)) ' 从第5列获取日期数据
            newarr(i, cols + 2) = VBA.TimeValue(arr(i, 5))
            'newarr(i, cols + 3) = application.WorksheetFunction.IfError()
            
           
            If VBA.TimeValue(arr(i, 5)) < VBA.TimeSerial(5, 0, 0) Then
                mealType = "夜宵"
            ElseIf VBA.TimeValue(arr(i, 5)) < VBA.TimeSerial(9, 0, 0) Then
                mealType = "早餐"
            ElseIf VBA.TimeValue(arr(i, 5)) < VBA.TimeSerial(15, 0, 0) Then
                mealType = "午餐"
            ElseIf VBA.TimeValue(arr(i, 5)) < VBA.TimeSerial(22, 0, 0) Then
                mealType = "晚餐"
            Else
                mealType = "夜宵"
            End If
  
            newarr(i, cols + 3) = mealType
            '在 VBA 中，Time 函数并不是一个内建的全局函数，而是 Application.WorksheetFunction.Time 的一部分，它通常用于 Excel 工作表函数。但是，在 VBA 代码中，我们通常使用 TimeSerial 函数来创建时间值，因为 Time 函数并不直接适用于 VBA 编程。
        Next i
        
    
     ' 写入增加的列中
        .Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1)).Value = Application.Index(newarr, 0, cols + 1) 'Application.Index 函数中的 0 用于指定返回一个一维数组
        .Range(.Cells(2, lastcol + 2), .Cells(lastrow, lastcol + 2)).Value = Application.Index(newarr, 0, cols + 2)
        .Range(.Cells(2, lastcol + 3), .Cells(lastrow, lastcol + 3)).Value = Application.Index(newarr, 0, cols + 3)
    
    
    
    End With

    
    Call ct
        
    ThisWorkbook.Sheets("汇总").Activate
    
    '排序
    Columns("A:A").Select
    With ActiveSheet.Sort
        With .SortFields
            .Clear
            .Add key:=Range("A2"), Order:=xlAscending
        End With
        .Header = xlGuess
        .MatchCase = False
        .SortMethod = xlPinYin
        .Orientation = xlSortColumns
        .SetRange rng:=Range("A1:E32")
        .Apply
    End With
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("汇总")
    
    For k = 1 To ws.Range("a" & ws.Rows.Count).End(xlUp).Row - 1
    
        ws.Range("B" & k + 1) = Application.WorksheetFunction.CountIfs(ThisWorkbook.Sheets("数据源").Columns("L:L"), ws.Range("a" & k + 1), ThisWorkbook.Sheets("数据源").Columns("N:N"), ws.Range("B1"))
        ws.Range("C" & k + 1) = Application.WorksheetFunction.CountIfs(ThisWorkbook.Sheets("数据源").Columns("L:L"), ws.Range("a" & k + 1), ThisWorkbook.Sheets("数据源").Columns("N:N"), ws.Range("C1"))
        ws.Range("D" & k + 1) = Application.WorksheetFunction.CountIfs(ThisWorkbook.Sheets("数据源").Columns("L:L"), ws.Range("a" & k + 1), ThisWorkbook.Sheets("数据源").Columns("N:N"), ws.Range("D1"))
        ws.Range("E" & k + 1) = Application.WorksheetFunction.CountIfs(ThisWorkbook.Sheets("数据源").Columns("L:L"), ws.Range("a" & k + 1), ThisWorkbook.Sheets("数据源").Columns("N:N"), ws.Range("E1"))
    
    Next
    
    '按时间段统计不重复的用餐人数
    
    Call cl '调用清除指定区域数据对象
    
    Call qc '调用去重重复数据后得就餐人数统计
    
End Sub

Sub ct() '日期去重，

Dim arr()
Dim dic As Object
Dim i As Long

Set dic = CreateObject("Scripting.Dictionary") ' 创建 Dictionary 对象

ThisWorkbook.Sheets("数据源").Activate

With ThisWorkbook.Sheets("数据源") ' 最好指定工作表，以防当前活动工作表不是预期的

    lastrow = Cells(.Rows.Count, 1).End(xlUp).Row
    lastcol = Cells(1, .Columns.Count).End(xlToLeft).Column
   
    arr = .Range("a2", .Cells(lastrow, lastcol)).Value '除表头外的数据区域

'创建字典
    For i = LBound(arr) To UBound(arr)
        dic(arr(i, lastcol - 2)) = 1 '主要是用key的值，赋值随便，此处取第3列数据，去重复值
    Next

End With

With ThisWorkbook.Sheets("汇总")
'Range("k1", Cells(1, Range("k1").Column - 1 + dic.Count)) = dic.Keys '不重复值按列显示
'Sheets("Sheet2").ListBox1.List = dic.Keys '不重复值取值到列表框显示
'不重复值按行显示

   
    Dim key As Variant
    Dim rowCounter As Long
    Dim rng As Range
    
    '清空指定区域数据
    Set rng = .Range("a2:E" & Cells(Rows.Count, 5).End(xlUp).Row)
    rng.ClearContents
    
    rowCounter = 2 ' 从第二行开始，写入去重后得日期数据
    For Each key In dic.Keys
        .Cells(rowCounter, 1).Value = key
        rowCounter = rowCounter + 1
    Next key

End With

End Sub

Sub qc() '数据去重后得人数统计
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim ws As Worksheet
Dim rngCopy As Range
Dim rngPaste As Range
Dim rng As Range
  
' 设置源工作表和目标工作表
Set wsSource = ThisWorkbook.Sheets("数据源")
Set wsDest = ThisWorkbook.Sheets("去重数据")
Set ws = ThisWorkbook.Sheets("汇总")

' 创建一个范围，它包含你想要复制的列
Set rngCopy = wsSource.Range("B:B,L:L,N:N")
      
' 激活目标工作表，并确定粘贴范围（从 A1 开始）
wsDest.Activate
wsDest.Cells.ClearContents
Set rngPaste = wsDest.Range("A1")
      
' 复制源范围并粘贴到目标范围
rngCopy.Copy Destination:=rngPaste
      
    
' 直接对 A 到 C 列进行去重操作
wsDest.Range("A1:C" & wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes





For k = 1 To ws.Range("a" & ws.Rows.Count).End(xlUp).Row - 1
    
    ws.Range("F" & k + 1) = Application.WorksheetFunction.CountIfs(wsDest.Columns("B:B"), ws.Range("a" & k + 1), wsDest.Columns("C:C"), ws.Range("B1"))
    ws.Range("G" & k + 1) = Application.WorksheetFunction.CountIfs(wsDest.Columns("B:B"), ws.Range("a" & k + 1), wsDest.Columns("C:C"), ws.Range("C1"))
    ws.Range("H" & k + 1) = Application.WorksheetFunction.CountIfs(wsDest.Columns("B:B"), ws.Range("a" & k + 1), wsDest.Columns("C:C"), ws.Range("D1"))
    ws.Range("I" & k + 1) = Application.WorksheetFunction.CountIfs(wsDest.Columns("B:B"), ws.Range("a" & k + 1), wsDest.Columns("C:C"), ws.Range("E1"))
    
Next

ws.Activate

End Sub
Sub cl() '清空指定区域数据
Dim ws As Worksheet
'Dim rng As Range
Set ws = ThisWorkbook.Sheets("汇总")



'Set rng = ws.Range("F2:I" & Cells(Rows.Count, 9).End(xlUp).Row)'当区域没有数据时，会清除掉标题
'rng.ClearContents
'rng.Select

ws.Range("F2", Cells(Rows.Count, 9)).ClearContents

End Sub

备注：

• 字典设置

Dim dic As Object

Set dic = CreateObject("Scripting.Dictionary") ' 创建 Dictionary 对象

• 数据清空和拷贝

Set wsSource = ThisWorkbook.Sheets("数据源")

Set wsDest = ThisWorkbook.Sheets("目标表")

' 创建一个范围，它包含你想要复制的列

Set rngCopy = wsSource.Range("B:B,L:L,N:N")

' 激活目标工作表，并确定粘贴范围（从 A1 开始）

wsDest.Activate

wsDest.Cells.ClearContents

Set rngPaste = wsDest.Range("A1")

' 复制源范围并粘贴到目标范围

rngCopy.Copy Destination:=rngPaste

• 选取数据区域

With ThisWorkbook.Sheets("数据源") ' 最好指定工作表，以防当前活动工作表不是预期的

lastrow = Cells(.Rows.Count, 1).End(xlUp).Row

lastcol = Cells(1, .Columns.Count).End(xlToLeft).Column

arr = .Range("a2", .Cells(lastrow, lastcol)).Value '除表头外的数据区域

end With

• 函数的调用

Application.WorksheetFunction.CountIfs（）

VBA.TimeValue(arr(i, 5)) < VBA.TimeSerial(22, 0, 0)

• 数组的赋值

' 将范围的值读取到数组中

arr = .Range(.Cells(2, 1), .Cells(lastrow, lastcol)).Value

' 获取原数组的行数和列数

Rows = UBound(arr, 1)

cols = UBound(arr, 2)

' 定义新的数组，大小比原数组多3列

ReDim newarr(1 To Rows, 1 To cols + 3)

' 将原数组的数据复制到新数组中，并在新数组的最后一列添加数据

For i = 1 To Rows

' 复制原数组的数据

For j = 1 To cols

newarr(i, j) = arr(i, j)

Next j

' 在新数组的最后一列添加数据

newarr(i, cols + 1) = VBA.DateValue(arr(i, 5)) ' 从第5列获取日期数据

newarr(i, cols + 2) = VBA.TimeValue(arr(i, 5))

Next