Second increment of loop overwrites first and so on . - excel

Question

I have been looking at this for to long so I am tossing it to those with more experience then I in hope of a copper or to of knowledge being tossed at me. The code runs with no errors.
The issue is that the second increment of the 1st loop overrides the first increments data range and so on. Loop 1 will populate rows 2:15. If I look at the address of lastrow it will show me the correct range of b16 as lastrow/cell in column to paste to , But as soon as the loop for the next objWorkBook runs it starts overwriting the fist increments cells rather then going to last row. I have a feeling i am missing something silly but it alludes me.
Any help or advice would be appreciated. I am relay interested in feed back. this will eventually process 100+ workbooks each adding roughly 1000 entries. I am concerned about the efficiency of my code. would using arrays speed things up? once things are caught up it will only process 2 workbooks a week. Again thank you for any pointer or advice your willing to share.
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

UNTESTED
Can you test this and tell me if you get any errors.
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

Answer 2

Ok so i figured it out after a nice long weekend away from it. With a Duh moment had
'open WB to consolidate too
Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"
Inside the loop that was suppose to copy to it so at each loop it reset my copy to WB causing what looked like overwriting.
I moved the open line out and the loop increments the paste to last cell with no issue. it did however break
Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name
Well sort of .. If I f8 down the code it works .. if I run the code it skips the line .. I dunno... .I will re post with another Question if I can't figure it out.