excel - 如何将具有上次修改日期指定范围的报告与 VBA 合并？
问题描述
我有 2 个要组合的宏。两者分别工作正常：
- 用于合并文件夹中所有 csv 文件的宏（在网上某处找到）：
Sub ImportCSV()
Dim strSourcePath As String
Dim strDestPath As String
Dim strFile As String
Dim strData As String
Dim x As Variant
Dim Cnt As Long
Dim r As Long
Dim c As Long
Application.ScreenUpdating = False
'Change the path to the source folder accordingly
strSourcePath = "\\lcwfsv1\users\e668714\Desktop\Workings\10. Merge Files\PathToMerge"
If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
'Change the path to the destination folder accordingly
strDestPath = "\\lcwfsv1\users\e668714\Desktop\Workings\10. Merge Files"
If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"
strFile = Dir(strSourcePath & "*.csv")
Do While Len(strFile) > 0
Cnt = Cnt + 1
If Cnt = 1 Then
r = 1
Else
r = Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
Open strSourcePath & strFile For Input As #1
If Cnt > 1 Then
Line Input #1, strData
End If
Do Until EOF(1)
Line Input #1, strData
x = Split(strData, ";")
For c = 0 To UBound(x)
Cells(r, c + 1).Value = Trim(x(c))
Next c
r = r + 1
Loop
Close #1
'Name strSourcePath & strFile As strDestPath & strFile
strFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then _
MsgBox "No CSV files were found...", vbExclamation
End Sub
- 在指定日期和时间（最后修改）之后仅合并 csv 文件的宏：
Sub Merge()
Call ExtractUserInfo
Call OpenCSVFiles
End Sub
Sub ExtractUserInfo()
Set mWB = ThisWorkbook
uPath = BackSlash(Main.Range("uPath").Text)
uDate = Main.Range("uDate").Value
uHour = Main.Range("uHour").Value
End Sub
Sub OpenCSVFiles()
Call OnStart
Dim arr, f
arr = AllFilesNewestFirst(uPath & "*.csv")
For Each f In arr
If Len(f) > 0 Then
If DateValue(FileDateTime(uPath & f)) < uDate Or (DateValue(FileDateTime(uPath & f)) = uDate And TimeValue(FileDateTime(uPath & f)) < uHour) Then Exit For
Set uFile = Workbooks.Open(fileName:=uPath & f, UpdateLinks:=False, Local:=True)
Call CopyData(uFile)
uFile.Close SaveChanges:=False
End If
Next f
Call OnEnd
MsgBox "Reports have been merged!"
End Sub
Function AllFilesNewestFirst(pattern)
Dim s As String
Dim oShell As Object
Dim oExec As Object, cmd
Set oShell = CreateObject("WScript.Shell")
cmd = "cmd /c dir """ & pattern & """ /A-D-H-S /b /o-d"
s = oShell.Exec(cmd).StdOut.readall()
AllFilesNewestFirst = Split(s, vbCrLf)
End Function
Sub CopyData(wb As Workbook)
Dim tRow As Double
Dim mRow As Double
tRow = wb.Sheets(1).UsedRange.Rows.Count
If tRow > 1 Then
mRow = mWB.Sheets(2).UsedRange.Rows.Count
Set rcop = Nothing
Set rng = Nothing
For Each rng In wb.Sheets(1).Range(Cells(2, 1), Cells(tRow, 32))
If Not rng Is Nothing Then
If Not rcop Is Nothing Then
Set rcop = Union(rng, rcop)
Else
Set rcop = rng
End If
Else
Set rcop = rng
End If
Next
If Not rcop Is Nothing Then
Intersect(rcop.EntireRow, wb.Sheets(1).Columns("A:AF")).Copy
mWB.Sheets(2).Range("a" & mRow + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
mWB.Sheets(2).Range("ag" & mRow + 1 & ":ag" & mWB.Sheets(2).UsedRange.Rows.Count) = wb.Name
End If
End If
End Sub
我想要这样做的原因是第一个宏要快很多倍，即使它默认合并所有文件。
这是我到目前为止所拥有的（只编辑了子 OpenCSVFiles，其余保持不变），我现在卡住了：
Sub OpenCSVFiles()
Call OnStart
Dim arr, f
arr = AllFilesNewestFirst(uPath & "*.csv")
Dim Cnt As Long
Dim r As Long
Dim c As Long
Dim x As Variant
Dim strData As String
For Each f In arr
If DateValue(FileDateTime(uPath & f)) < uDate Or (DateValue(FileDateTime(uPath & f)) = uDate And TimeValue(FileDateTime(uPath & f)) < uHour) Then Exit For
If Len(f) > 0 Then
Cnt = Cnt + 1
If Cnt = 1 Then
r = 1
Else
r = Cells(Merged.Rows.Count, "A").End(xlUp).Row + 1
End If
Open uPath & f For Input As #1
If Cnt > 1 Then
Line Input #1, strData
End If
Do Until EOF(1)
Line Input #1, strData
x = Split(strData, ";")
For c = 0 To UBound(x)
Merged.Cells(r, c + 1).Value = Trim(x(c))
Merged.Cells(r, c + 2).Value = f
Next c
r = r + 1
Loop
Close #1
End If
Next f
Call OnEnd
MsgBox "Reports have been merged!"
End Sub
问题是：
- 它在正确的时间点开始合并（例如 2021 年 6 月 1 日，17:05），但是由于某种原因它在几天后停止。
- 它在第一行和下一行之间的工作表中创建了 8 个空白行，我无法在代码中发现它发生的原因。
有什么建议么？
非常感谢！