Excel 合并工具 将文件复制到目标工作表中与操作日志记录

指定文件夹中读取符合条件的 Excel 文件，将其中的数据按照一定规则复制到目标工作表中，并进行相关的日志记录和工作簿保存操作。

先看下 excel 的结构

合并的结果

log 记录

vba 代码

Sub DeltaCheck()
' 作者和创建时间的注释

    ' 定义工作表变量
    Dim ws As Worksheet
    ' 以下几行暂时禁用了一些 Excel 的默认功能，以提高运行效率和避免干扰
'    Application.ScreenUpdating = 0
'    Application.Calculation = xlCalculationManual
'    Application.DisplayAlerts = False

    ' 设置相关工作表
    Set shtIND = ThisWorkbook.Worksheets("设置")

    '<<<<<<  设置参数
    ' 定义各种工作簿、工作表、文件夹路径、行列范围等参数
    Set wbComin = ThisWorkbook
    filFr1 = shtIND.Range("B3")
    shtFr1 = shtIND.Range("B4")
    fldFr1 = shtIND.Range("B5") & "\"
    shtTo1 = shtIND.Range("B8")
    vT1 = shtIND.Range("B9")
    vTr = vT1 + 1  ' 标题的下一行
    vCF = shtIND.Range("E4")  ' 复制的列起始
    vCT = shtIND.Range("F4")  ' 复制的列结束
    vCFn = shtIND.Range("E5")  ' 复制的列起始编号
    vCTN = shtIND.Range("F5")  ' 复制的列结束编号

    vPF = shtIND.Range("E8")  ' 粘贴的列起始
    vPT = shtIND.Range("F8")  ' 粘贴的列结束
    vPFn = shtIND.Range("E9")  ' 粘贴的列起始编号
    vPTn = shtIND.Range("F9")  ' 粘贴的列结束编号
    vPFile = shtIND.Range("G8")
    sheetName = shtTo1

    '<<<<< 日志相关
    ' 处理"LOG"工作表，如果不存在则创建，存在则删除后重新创建
    On Error Resume Next
        Set ws = Worksheets("LOG")
        If Err Then       ' 如果"LOG"工作表不存在
            shtIND.Select
            ActiveWorkbook.Sheets.Add After:=shtIND
            ActiveSheet.Name = "LOG"
            On Error GoTo 0
         Else
            ' 如果"LOG"工作表存在
            Sheets("LOG").Select
            Application.DisplayAlerts = False
            Sheets("LOG").Delete
            shtIND.Select
            ActiveWorkbook.Sheets.Add After:=shtIND
            ActiveSheet.Name = "LOG"
        End If
    Set shtLog = ThisWorkbook.Worksheets("LOG")
    ' 设置"LOG"工作表的表头
    shtLog.Range("A1").Value = "File Name"
    shtLog.Range("B1").Value = "Copy From Area"
    shtLog.Range("C1").Value = "Copy To Area"
    shtLog.Range("D1").Value = "Row Count"
    shtLog.Range("E1").Value = "Log Time"
    LogRow = 2

    '<<<< 设置"复制到"的工作表
    ' 类似"LOG"工作表的处理，对指定的目标工作表进行处理
    On Error Resume Next
        Set ws = Worksheets(sheetName)
        If Err Then       ' 如果目标工作表不存在
            shtIND.Select
            ActiveWorkbook.Sheets.Add After:=shtIND
            ActiveSheet.Name = sheetName
            On Error GoTo 0
         Else
            ' 如果目标工作表存在
            Sheets(sheetName).Select
            Application.DisplayAlerts = False
            Sheets(sheetName).Delete
            shtIND.Select
            ActiveWorkbook.Sheets.Add After:=shtIND
            ActiveSheet.Name = sheetName
        End If
    Set shtA = ThisWorkbook.Worksheets(shtTo1)
    shtA.Select
    shtA.Range(Cells(1, vPTn + 1), Cells(1, vPTn + 1)).Value = "FileName"

    ' 开始复制 Excel 数据
    MyFile = Dir(fldFr1)
    Do While MyFile <> " "
        If MyFile = "" Then Exit Do
        If MyFile Like filFr1 Then
            AEndRow = shtA.Range("A90000").End(xlUp).Row

            ' 复制新数据
            Set wbOpen1 = Workbooks.Open(fldFr1 & "\" & MyFile)
            Set shtOpen1 = wbOpen1.Worksheets(shtFr1)
            shtOpen1.Select
            OEndRow = shtOpen1.Range("A90000").End(xlUp).Row

            ' 根据不同情况进行复制和粘贴操作，并记录日志
            If OEndRow < vTr Then
                ' <<<< log
                shtLog.Range("A" & LogRow).Value = MyFile
                shtLog.Range("B" & LogRow).Value = ""
                shtLog.Range("C" & LogRow).Value = ""
                shtLog.Range("D" & LogRow).Value = OEndRow - vT1
                shtLog.Range("E" & LogRow).Value = Now()
            Else
                If AEndRow <= vTr Then
                    shtOpen1.Range(vCF & "1:" & vCT & OEndRow).Copy Destination:=shtA.Range("A1:" & vPT & OEndRow)
                    shtA.Range(vPFile & "2:" & vPFile & (OEndRow)).Value = MyFile
                Else
                    shtOpen1.Range(vCF & vTr & ":" & vCT & OEndRow).Copy Destination:=shtA.Range("A" & AEndRow + 1 & ":" & vPT & AEndRow + OEndRow - vT1)
                    shtA.Range(vPFile & AEndRow + 1 & ":" & vPFile & (AEndRow + OEndRow - vT1)).Value = MyFile
                End If
                ' <<<< log
                shtLog.Range("A" & LogRow).Value = MyFile
                shtLog.Range("B" & LogRow).Value = vCF & vTr & ":" & vCT & OEndRow
                shtLog.Range("C" & LogRow).Value = "A" & AEndRow + 1 & ":" & vPT & AEndRow + OEndRow - vT1
                shtLog.Range("D" & LogRow).Value = OEndRow - vT1
                shtLog.Range("E" & LogRow).Value = Now()
            End If
            LogRow = LogRow + 1
            wbOpen1.Close savechanges:=False
        End If

        ' 处理下一个文件
        MyFile = Dir
    Loop

    shtIND.Select

    ' 根据工作簿名称进行处理并保存
    thisFileName = ThisWorkbook.Name
    If IsNumeric(Left(thisFileName, 8)) Then
      thisFileName = Right(thisFileName, Len(thisFileName) - 8)
    End If
    SaveToFileName = ThisWorkbook.Path & "\" & Format(Date, "yyyymmdd") & thisFileName
    wbComin.SaveAs Filename:=SaveToFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

    ' 再次保存工作簿
    SaveToFileName = ThisWorkbook.Path & "\" & shtIND.Range("AA1")
    wbComin.SaveAs Filename:=SaveToFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    shtIND.Select

    ' 恢复 Excel 的默认设置
'    Application.Calculation = xlCalculationAutomatic
'    Application.ScreenUpdating = True
'    Application.DisplayAlerts = True
End Sub