我一直在关注这个问题，所以我把它扔给那些有更多经验的人，然后我希望铜或知识被扔给我。代码运行没有错误。
问题是第一个循环的第二个增量会覆盖第一个增量数据范围，依此类推。循环1将填充行2:15。如果我查看lastrow的地址，它会显示正确的b16范围作为lastrow / cell in column to paste，但是一旦下一个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
答案 0 :(得分：0)
<强> UNTESTED
你可以测试一下并告诉我你是否有任何错误。
Option Explicit
Sub parse()
Dim MyColumn As String, Here As String, OldFilePath As String, NewFilePath As String
Dim strPath As String, strPathused As String
Dim objfso As FileSystemObject, objFolder As Folder, objfile As Object
Dim objWorkbook As Workbook, wbPlan As Workbook
Dim SRCwb As Worksheet, DSTws As Worksheet
Dim lastrow As Long, lastrowN As Long
Dim SRCrange1 As Range, SRCrange2 As Range
Dim DSTheader As Range, SRCheader As Range, x As Range, y As Range
Dim SRCrngCP1 As Range, SRCrngCP2 As Range
Application.DisplayAlerts = False
strPath = "C:\prodplan"
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
Set objWorkbook = Workbooks.Open(objfile.Path)
Set SRCwb = objWorkbook.Worksheets("plan")
Set SRCrange1 = SRCwb.Range("B6:I7")
Set SRCrange2 = SRCwb.Range("K6:P7")
' Set path for move to at end of script
strPathused = "C:\prodplan\used\" & objWorkbook.Name
'open WB to consolidate too
Set wbPlan = Workbooks.Open("C:\prodplan\compiled\plancon.xlsx")
Set DSTws = wbPlan.Worksheets("data")
lastrow = DSTws.Range("B" & DSTws.Rows.Count).End(xlUp).Row + 1
With DSTws.Range("B" & lastrow)
SRCrange1.Copy
.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
lastrowN = DSTws.Range("B" & DSTws.Rows.Count).End(xlUp).Row
.Range("A" & lastrow & ":A" & lastrowN).Value = objWorkbook.Name
lastrow = lastrowN + 1
SRCrange2.Copy
.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
lastrowN = DSTws.Range("B" & DSTws.Rows.Count).End(xlUp).Row
.Range("A" & lastrow & ":A" & lastrowN).Value = objWorkbook.Name
End With
Set DSTheader = DSTws.Range("D1:BW1")
Set SRCheader = SRCwb.Range("A1:A110")
For Each x In DSTheader
For Each y In SRCheader
Set SRCrngCP1 = SRCwb.Range(y.Offset(0, 1).Address & ":" & y.Offset(0, 8).Address)
Set SRCrngCP2 = SRCwb.Range(y.Offset(0, 10).Address & ":" & y.Offset(0, 15).Address)
If y > 0 Then
If x = y Then
Here = x.Address
MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
lastrow = DSTws.Range(MyColumn & DSTws.Rows.Count).End(xlUp).Row + 1
With DSTws.Range("B" & lastrow)
SRCrngCP1.Copy
.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
lastrow = DSTws.Range(MyColumn & DSTws.Rows.Count).End(xlUp).Row + 1
SRCrngCP2.Copy
.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
End With
If x = y Then Exit For
End If
End If
Next y
Next x
objWorkbook.Close False
OldFilePath = objfile 'original file location
NewFilePath = strPathused ' new file location
Name OldFilePath As NewFilePath ' move the file
End If
Next
End Sub
答案 1 :(得分：0)
好的，所以我在一个漫长的周末远离它之后想出来了。有一个Duh时刻已经
'open WB to consolidate too
Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"
在循环内部，假设要复制到它，所以在每个循环中它将我的副本重置为WB，导致看起来像覆盖。
我将打开的行移开，循环将粘贴增加到最后一个单元格而没有问题。然而它确实打破了
Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name
好吧..如果我f8代码它可以工作..如果我运行代码它跳过线..我不知道...。如果我无法弄明白，我将重新发布另一个问题