如何使用VBA在Excel表格中直接实现去重、提取表头及条件求和

实现逻辑 #

• 用字典去重获取所有不重复日期、Done列的不重复姓名作为表头
• 数组批量读写数据，避免逐单元格操作，运行效率远高于单元格遍历或公式写入
• 自动匹配表头名称，无需单独指定「Peter」等列的位置，适配性更强

完整可运行代码 #

Sub 交叉表求和()
    Dim sbl As ListObject: Set sbl = ActiveWorkbook.Sheets(4).ListObjects("Tab_1") '源表
    Dim tbl As ListObject: Set tbl = ActiveWorkbook.Sheets(4).ListObjects("Tab_2") '目标表
    Dim sourceArr, resArr, dateDict As Object, nameDict As Object
    Dim i As Long, dateIdx As Long, nameIdx As Long, sumCol As Long, nameCol As Long, dateCol As Long
    
    ' 配置源表列索引，根据实际结构调整：1=第一列，以此类推
    dateCol = 1 '源表日期列位置
    sumCol = 2 '源表要求和的数值列位置
    nameCol = 3 '源表Done列（存姓名）位置
    
    Set dateDict = CreateObject("Scripting.Dictionary")
    Set nameDict = CreateObject("Scripting.Dictionary")
    
    ' 读取源表所有数据到数组
    sourceArr = sbl.DataBodyRange.Value
    
    ' 第一步：提取不重复日期和姓名
    For i = 1 To UBound(sourceArr)
        ' 去重日期
        If Not dateDict.exists(sourceArr(i, dateCol)) Then
            dateDict.Add sourceArr(i, dateCol), dateDict.Count + 1
        End If
        ' 去重姓名（Done列取值）
        If Not nameDict.exists(sourceArr(i, nameCol)) Then
            nameDict.Add sourceArr(i, nameCol), nameDict.Count + 1
        End If
    Next i
    
    ' 第二步：重置目标表结构
    ' 清空目标表旧数据
    If Not tbl.DataBodyRange Is Nothing Then tbl.DataBodyRange.Delete
    ' 清空旧表头，保留第一列的「日期」表头
    Do While tbl.ListColumns.Count > 1
        tbl.ListColumns(tbl.ListColumns.Count).Delete
    Loop
    ' 添加新的姓名表头
    For Each k In nameDict.keys
        tbl.ListColumns.Add.Name = k
    Next
    ' 给目标表添加空行，行数等于不重复日期的数量
    tbl.ListRows.Add Count:=dateDict.Count
    
    ' 第三步：初始化结果数组，数组维度=日期数 x (1+姓名数)
    ReDim resArr(1 To dateDict.Count, 1 To 1 + nameDict.Count)
    
    ' 写入第一列的日期
    For Each k In dateDict.keys
        resArr(dateDict(k), 1) = k
    Next
    
    ' 第四步：遍历源表求和，写入对应位置
    For i = 1 To UBound(sourceArr)
        dateIdx = dateDict(sourceArr(i, dateCol))
        nameIdx = nameDict(sourceArr(i, nameCol)) + 1 ' 第一列是日期，所以姓名列从第2位开始
        resArr(dateIdx, nameIdx) = resArr(dateIdx, nameIdx) + sourceArr(i, sumCol)
    Next i
    
    ' 第五步：一次性写入结果到目标表
    tbl.DataBodyRange.Value = resArr
End Sub

补充说明 #

如果仅需要单独写入「Peter」列的结果，可以直接调用SumIfs实现，参数格式如下：

' 单独计算Peter列的所有日期求和结果
Dim peterCol As Long
' 自动定位目标表中Peter列的位置，不会因为列顺序变化失效
peterCol = tbl.ListColumns("Peter").Index

Dim j As Long
For j = 1 To tbl.ListRows.Count
    currDate = tbl.DataBodyRange(j, 1).Value
    tbl.DataBodyRange(j, peterCol) = Application.WorksheetFunction.SumIfs( _
        sbl.ListColumns(sumCol).DataBodyRange, _
        sbl.ListColumns(dateCol).DataBodyRange, currDate, _
        sbl.ListColumns(nameCol).DataBodyRange, "Peter" _
    )
Next j

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