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
原文地址:https://blog.csdn.net/chenchihwen/article/details/144372385
免责声明:本站文章内容转载自网络资源,如本站内容侵犯了原著者的合法权益,可联系本站删除。更多内容请关注自学内容网(zxcms.com)!