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

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.