循環的第二次增量首先覆蓋，依此類推。

Question

我一直在考慮這個問題，所以我把它扔給那些有更多經驗的人，然後我希望銅或知識被扔在我身上。代碼運行時沒有錯誤。

問題是第一個循環的第二個增量會覆蓋第一個增量數據範圍等等。循環1將填充行2：15。如果我看一下lastrow的地址，它會向我顯示正確的b16範圍，作爲要粘貼的列中的lastrow/cell，但只要下一個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 

Answer 1

好吧，所以我想出了一個很好的長週末後離開它。隨着咄時刻有

這是想複製它，因此在每個循環將其重置我的副本，以WB導致看上去像覆蓋在循環中。

我把開放的線移出，循環增加了粘貼到最後一個單元沒有問題。但是它沒有打破

Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name 

好樣的。如果我F8下它的工作原理的代碼..如果我運行它跳過行代碼..我不知道......我會再與後一個問題如果我無法弄清楚。

Answer 2

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