我一直在看这个很长时间,所以我把它扔给那些比我更有经验的人,希望铜或知识被扔给我。代码运行没有错误。
问题是第一个循环的第二个增量覆盖了第一个增量数据范围,依此类推。循环 1 将填充行 2:15。如果我查看 lastrow 的地址,它将显示 b16 的正确范围作为要粘贴到的列中的 lastrow/单元格,但是一旦下一个 objWorkBook 的循环运行,它就会开始覆盖第一个增量单元格而不是最后一个排。我有一种感觉,我错过了一些愚蠢的东西,但它暗示了我。
任何帮助或建议将不胜感激。我对反馈感兴趣。这最终将处理 100 多个工作簿,每个工作簿添加大约 1000 个条目。我担心我的代码的效率。使用数组会加快速度吗?一旦事情赶上,它每周只会处理 2 个工作簿。再次感谢您愿意分享的任何指示或建议。
Option Explicit
Sub parse()
Application.DisplayAlerts = False
'Application.EnableCancelKey = xlDisabled
Dim strPath As String, strPathused As String
strPath = "C:\prodplan"
Dim objfso As FileSystemObject, objFolder As Folder, objfile As Object
Set objfso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objfso.GetFolder(strPath)
'Loop through objWorkBooks
For Each objfile In objFolder.Files
If objfso.GetExtensionName(objfile.Path) = "xlsx" Then
Dim objWorkbook As Workbook
Set objWorkbook = Workbooks.Open(objfile.Path)
' Set path for move to at end of script
strPathused = "C:\prodplan\used\" & objWorkbook.Name
'open WB to consolidate too
Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"
'Range management WB
Dim SRCwb As Worksheet, SRCrange1 As Range, SRCrange2 As Range, lastrow As Range
Set SRCwb = objWorkbook.Worksheets("plan")
Set SRCrange1 = SRCwb.Range("b6:i7")
Set SRCrange2 = SRCwb.Range("k6:p7")
'Range management destination WB
Dim DSTws As Worksheet
Set DSTws = Workbooks("plancon.xlsx").Worksheets("data")
'start header dates and shifts copy from objworkbook to consolidated WB
Set lastrow = Workbooks("plancon.xlsx").Worksheets("data").Range("b" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)
SRCrange1.copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name
Set lastrow = Workbooks("plancon.xlsx").Worksheets("data").Range("b" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)
SRCrange2.copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name
'Begin loop to copy content.
Dim DSTheader As Range
Set DSTheader = DSTws.Range("d1:bw1")
Dim SRCheader As Range
Set SRCheader = SRCwb.Range("a1:a110")
Dim x As Variant
Dim y As Variant
Dim matchEXIT As Boolean
matchEXIT = False
For Each x In DSTheader
For Each y In SRCheader
Dim SRCrngCP1 As Range
Set SRCrngCP1 = SRCwb.Range(y.Offset(0, 1).Address & ":" & y.Offset(0, 8).Address)
Dim SRCrngCP2 As Range
Set SRCrngCP2 = SRCwb.Range(y.Offset(0, 10).Address & ":" & y.Offset(0, 15).Address)
If y > 0 Then
If x = y Then
Dim MyColumn As String
Dim Here As String
Here = DSTws.Range(x.Address).Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
Set lastrow = DSTws.Range(MyColumn & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)
SRCrngCP1.copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
Set lastrow = DSTws.Range(MyColumn & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)
SRCrngCP2.copy
lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
If x = y Then matchEXIT = True
If matchEXIT = True Then Exit For
End If
End If
Next y
matchEXIT = False
Next x
MsgBox x
objWorkbook.Close False
'Move proccesed file to new Dir
Dim OldFilePath As String
Dim NewFilePath As String
OldFilePath = objfile 'original file location
NewFilePath = strPathused ' new file location
Name OldFilePath As NewFilePath ' move the file
End If
Set lastrow = Workbooks("plancon.xlsx").Worksheets("data").Range("b" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)
Next
End Sub