VBA实现Excel数据自动分类与统计

在企业管理中，特别是在物流、安装服务等行业中，对送货师傅和安装人员的费用统计是日常运营中不可或缺的一环。这些费用数据往往散落在各种Excel表格中，难以快速、准确地汇总和分析。为了提升工作效率，减少人工错误，我们设计了一个基于VBA（Visual Basic for Applications）的Excel宏，名为“主程序”，该宏能够自动从原始数据表中识别送货师傅、安装人员及其对应的费用，并将这些信息汇总到一个新的工作表“汇总表”中，同时计算出每位送货师傅的总运费和每位安装人员的总安装费。

此外，为了提供更全面的数据分析支持，我们还附加了一个名为“子程序”的子程序，它能够在“汇总表”中自动计算每位送货师傅和安装人员的总费用（运费加安装费），并在D列显示，同时在表格底部添加总计行，显示所有费用的总和。此功能不仅简化了数据汇总过程，还使得费用分析更加直观、便捷。

本VBA宏的设计充分考虑了数据的灵活性和可扩展性，能够自动适应不同格式的数据表，只需确保原数据表（本例中为“源表”）的列标题中包含“送货师傅”、“安装人员”和“运费”等关键字即可。通过此宏，企业可以大大提高费用统计的效率和准确性，为管理决策提供有力的数据支持。

代码如下：

Sub 主程序()
    Dim ws As Worksheet
    Dim summaryWs As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim deliveryCols As Collection
    Dim installCols As Collection
    Dim deliveryFeeCols As Collection
    ' 设置原数据工作表
    Set ws = ThisWorkbook.Sheets("源表")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
    lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
    ' 查找或创建Summary工作表
    On Error Resume Next
    Set summaryWs = ThisWorkbook.Sheets("汇总表")
    If summaryWs Is Nothing Then
        Set summaryWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        summaryWs.Name = "汇总表"
    End If
    On Error GoTo 0  ' 恢复正常错误处理
    ' 清空Summary表
    summaryWs.Cells.Clear
    Set deliveryCols = New Collection
    Set installCols = New Collection
    Set deliveryFeeCols = New Collection
    ' 查找包含"送货师傅"、"安装人员"、"运费"的列
    For i = 1 To lastCol
        If InStr(ws.Cells(2, i).Value, "送货师傅") > 0 Then
            deliveryCols.Add i
        ElseIf InStr(ws.Cells(2, i).Value, "安装人员") > 0 Then
            installCols.Add i
        ElseIf InStr(ws.Cells(2, i).Value, "运费") > 0 Then
            deliveryFeeCols.Add i
        End If
    Next i
    Dim nameDict As Object
    Set nameDict = CreateObject("Scripting.Dictionary")
    ' 收集姓名并初始化费用统计
    For i = 3 To lastRow  ' 从第三行开始遍历数据行
        ' 收集送货师傅
        For Each col In deliveryCols
            If Not nameDict.Exists(ws.Cells(i, col).Value) And ws.Cells(i, col).Value <> "" Then
                nameDict.Add ws.Cells(i, col).Value, Array(0, 0)
            End If
        Next col
        ' 收集安装人员
        For Each col In installCols
            If Not nameDict.Exists(ws.Cells(i, col).Value) And ws.Cells(i, col).Value <> "" Then
                nameDict.Add ws.Cells(i, col).Value, Array(0, 0)
            End If
        Next col
    Next i
    ' 统计费用
    For i = 3 To lastRow
        ' 累加送货师傅的运费
        For Each col In deliveryCols
            If ws.Cells(i, col).Value <> "" Then
                Dim fees() As Variant
                fees = nameDict(ws.Cells(i, col).Value)
                For Each feeCol In deliveryFeeCols
                    fees(0) = fees(0) + ws.Cells(i, feeCol).Value
                Next feeCol
                nameDict(ws.Cells(i, col).Value) = fees
            End If
        Next col
        ' 累加安装人员的安装费
        For Each col In installCols
            If ws.Cells(i, col).Value <> "" Then
                Dim personName As String
                personName = ws.Cells(i, col).Value
                fees = nameDict(personName)
                ' 假设安装费在安装人员列的右侧
                If col + 1 <= lastCol Then
                    fees(1) = fees(1) + ws.Cells(i, col + 1).Value
                End If
                nameDict(personName) = fees
            End If
        Next col
    Next i
    ' 输出结果到Summary表
    summaryWs.Cells(1, 1).Value = "姓名"
    summaryWs.Cells(1, 2).Value = "总运费"
    summaryWs.Cells(1, 3).Value = "总安装费"
    Dim outputRow As Long
    outputRow = 2  ' 从第二行开始输出
    Dim key As Variant
    For Each key In nameDict.keys
        summaryWs.Cells(outputRow, 1).Value = key
        fees = nameDict(key)
        summaryWs.Cells(outputRow, 2).Value = Round(fees(0), 1)
        summaryWs.Cells(outputRow, 3).Value = Round(fees(1), 1)
        outputRow = outputRow + 1
    Next key
Call 子程序
End Sub
Sub 子程序()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    ' 设置要操作的工作表
    Set ws = ThisWorkbook.Sheets("汇总表") ' 修改为你的工作表名
    ' 查找A列最后一行有数据的单元格
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    ' 在D列第一行写入标题
    ws.Cells(1, "D").Value = "合计"
    ' 遍历A列和B列的数据，从第二行开始（假设第一行是标题）
    For i = 2 To lastRow
        ' 对A列和B列的当前行进行求和，并将结果放在D列的当前行
'        ws.Cells(i, "D").Value = ws.Cells(i, "B").Value + ws.Cells(i, "C").Value
        ws.Cells(i, "D").Value = Round(ws.Cells(i, "B").Value + ws.Cells(i, "C").Value, 1)
        totalSum = totalSum + ws.Cells(i, "B").Value + ws.Cells(i, "C").Value
    Next i
    ws.Cells(lastRow + 1, "D").Value = "总计"
    ws.Cells(lastRow + 2, "D").Value = totalSum
    ' 设置A列到D列的格式：文字居中和添加边框
    With ws.Range("A1:D" & lastRow + 2)
        .HorizontalAlignment = xlCenter ' 文本居中
        ' 添加边框
        With .Borders
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
    End With
End Sub