Excel VBA开发需求：差旅工作簿项目公里数汇总至主工作簿

阿华AIGC实验室

2026-5-14

完善差旅费用工作簿汇总的VBA代码

嘿，我来帮你搞定按项目编号合并累加KM数的需求！你的现有代码已经搭好了遍历文件夹的基础框架，现在只需要加上**字典（Dictionary）**这个高效工具，就能轻松实现相同项目KM数累加、不同项目新增行的功能。

完整代码实现

Sub ConsolidateTravelExpenses()
    Dim master As Worksheet
    Dim directory As String, fileName As String
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim projectID As String, kmValue As Double
    Dim kmDict As Object ' 用字典存储项目编号与累计KM数
    Dim lastRow As Long, i As Long
    
    ' 初始化主工作表
    Set master = ThisWorkbook.Worksheets(1)
    ' 创建字典对象（后期绑定，无需手动添加引用）
    Set kmDict = CreateObject("Scripting.Dictionary")
    kmDict.CompareMode = vbTextCompare ' 项目编号不区分大小写，按需调整
    
    ' 替换为你的目标文件夹路径（注意末尾加反斜杠）
    directory = "C:\YourTravelFilesFolder\"
    fileName = Dir(directory & "*.xlsx") ' 仅处理xlsx格式文件，可按需修改
    
    Application.ScreenUpdating = False ' 关闭屏幕更新提升运行速度
    
    While fileName <> ""
        Set targetWB = Workbooks.Open(directory & fileName)
        ' 定位到存储KM数据的工作表（根据你的实际表名调整）
        Set targetWS = targetWB.Worksheets("Ewidencja przebiegu pojazdu")
        
        ' 遍历目标区域的项目与KM数据（假设项目在E26:E35，KM在F26:F35，按需修改）
        For i = 26 To 35
            projectID = Trim(targetWS.Cells(i, "E").Value)
            kmValue = targetWS.Cells(i, "F").Value
            
            ' 仅处理非空的项目编号
            If projectID <> "" Then
                If kmDict.Exists(projectID) Then
                    ' 项目已存在，累加KM数
                    kmDict(projectID) = kmDict(projectID) + kmValue
                Else
                    ' 项目不存在，添加新条目
                    kmDict(projectID) = kmValue
                End If
            End If
        Next i
        
        ' 关闭目标工作簿，不保存修改
        targetWB.Close SaveChanges:=False
        ' 获取下一个文件
        fileName = Dir
    Wend
    
    ' 将字典中的汇总数据写入主工作表
    ' 清空主表原有数据（若需保留表头，从第2行开始清空）
    master.Range("A2:B" & master.Cells(master.Rows.Count, "A").End(xlUp).Row).ClearContents
    
    ' 批量写入汇总结果
    lastRow = 2 ' 假设第1行是表头：A1="项目编号"，B1="累计KM数"
    For Each projectID In kmDict.Keys
        master.Cells(lastRow, "A").Value = projectID
        master.Cells(lastRow, "B").Value = kmDict(projectID)
        lastRow = lastRow + 1
    Next projectID
    
    Application.ScreenUpdating = True ' 恢复屏幕更新
    MsgBox "差旅KM数汇总完成！", vbInformation
End Sub

关键逻辑说明

字典的核心作用：字典是VBA中高效的键值对存储工具，用项目编号作为唯一键，累计KM数作为对应值，能瞬间判断项目是否已存在，避免了逐行查找的低效操作。

动态范围适配：如果你的项目/KM数据行数不固定，可以用End(xlUp)获取实际最后一行，替换固定的遍历范围：

Dim lastTargetRow As Long
lastTargetRow = targetWS.Cells(targetWS.Rows.Count, "E").End(xlUp).Row
For i = 26 To lastTargetRow ' 从起始行到实际数据最后一行
    ' 处理逻辑不变
Next i