Macro to open Multiple Files in a Folder and Copy Key Elements out but will not find correct last available cell

[balla506]

I am trying to take some data out of a couple hundred sheets. Basically I open each one by one pull the key data and find the last available cell in column D as the start point to paste to from the next file. It seems to keep selecting row 23 (even though the cells up to 2 are empty) and then the next file starts on line 76 leaving a bunch of empty space. I have no idea why it seems to be selecting these cells no matter what I do. I have gone line by line and it seems to loop through the files correctly and grab the correct info, just pastes it in the wrong location. Any help would be appreciated. Thanks.

Sub Copy_Info()
Dim MainWkbk As Workbook
Dim NextWkbk As Workbook
Dim folderPath As String
Dim filename As String
Dim wb As Workbook


Set MainWkbk = ActiveWorkbook


  
    folderPath = "C:\Users\f18023b\Documents\Test\" 'change to suit
    
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
    
    filename = Dir(folderPath & "*.xls")
    Do While filename <> ""
      Application.ScreenUpdating = False
        Set wb = Workbooks.Open(folderPath & filename)


'Open one File


Set NextWkbk = ActiveWorkbook
lmaxrows = Cells(Rows.Count, "D").End(xlUp).Row
    NextWkbk.Activate
    Sheets("Inputs").Select
    Range("B3").Select
    Selection.Copy
    Windows("TSM Rollup .xlsm").Activate
    Range("A" & lmaxrows + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
NextWkbk.Activate
    Range("B4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("TSM Rollup .xlsm").Activate
    Range("B" & lmaxrows + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
NextWkbk.Activate
    Range("B5:E5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("TSM Rollup .xlsm").Activate
    Range("C" & lmaxrows + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
NextWkbk.Activate
    Sheets("2015 Plan").Select
    Range("A63:A77").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("TSM Rollup .xlsm").Activate
    Range("D" & lmaxrows + 1).Select
    ActiveSheet.Paste
NextWkbk.Activate
ActiveWorkbook.Close False
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[BiocideJ]

Your code is confusing me with its workbook definitions (among other things).

You have wb and NextWkbk which I believe are the same...
You also have MainWkbk and Windows("TSM Rollup .xlsm") which I also suspect are the same.

Can you confirm for me that you are trying to:
copy Cell B3 FROM NextWkbk.Sheets("Inputs") INTO MainWkbk in the next available cell in column A
copy Cell B4 FROM NextWkbk.Sheets("Inputs") INTO MainWkbk in the next available cell in column B
copy Cells B5:E5 FROM NextWkbk.Sheets("Inputs") INTO MainWkbk in the next available cells in columns C:F

Then Cells A63:A77 FROM NextWkbk.Sheets("2015 Plan") INTO MainWkbk in the next available cell in column D (overwriting what was already there and also spanning 14 rows down (which will later be overwritten on the next line)

The last one I'm sure is wrong, but I need much more information as to what you are actually trying to do to be able to diagnose why it isn't doing it.

EDIT: In direct response to your question, I believe your problem is you're getting the lmaxrow from NextWkbk to determine the row to write into MainWkbk, but once that problem is fixed I think you are going to have many other problems here.

 

[JLGWhiz]

I took the liberty of modifying your Dim and Set statements and eliminating the Activate and Select statements to make the code more efficient and easier to read. Now we need to see if it will do what you want.

Sub Copy_Info2()
Dim MainWkbk As Workbook, sh As Worksheet
Dim NextWkbk As Workbook
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
Set MainWkbk = Workbooks("TSM Rollup .xlsm")
Set sh = MainWkbk.Sheets(1) 'Edit sheet name
    folderPath = "C:\Users\f18023b\Documents\Test\" 'change to suit
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
    filename = Dir(folderPath & "*.xls")
    Do While filename <> ""
      Application.ScreenUpdating = False
    Set NextWkbk = Workbooks.Open(folderPath & filename)
    'Open one File
    Set sSh = NextWkbk.Sheets("Inputs")
    Set nSh = NextWkbk.Sheets("2015 Plan")
    lmaxrows = sh.Cells(Rows.Count, "D").End(xlUp).Row
        sSh.Range("B3").Copy
        sh.Range("A" & lmaxrows + 1).PasteSpecial xlPasteValues
        sSh.Range("B4").Copy
        sh.Range("B" & lmaxrows + 1).PasteSpecial xlPasteValues
        sSh.Range("B5:E5").Copy
        sh.Range("C" & lmaxrows + 1).PasteSpecial xlPasteValues
    nSh.Sheets("2015 Plan").Range("A63:A77").Copy sh.Range("D" & lmaxrows + 1)
ActiveWorkbook.Close False
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[balla506]

Just had to change nSh.Sheets("2015 Plan").Range("A63:A77").Copy sh.Range("D" & lmaxrows + 1) to nSh.Range("A63:A77").Copy sh.Range("D" & lmaxrows + 1) and worked like a charm. Thanks so much for your help on this. Biocide J thanks for giving it a go even though the code wasn't the clearest.

 

[JLGWhiz]

Just had to change nSh.Sheets("2015 Plan").Range("A63:A77").Copy sh.Range("D" & lmaxrows + 1) to nSh.Range("A63:A77").Copy sh.Range("D" & lmaxrows + 1) and worked like a charm. Thanks so much for your help on this. Biocide J thanks for giving it a go even though the code wasn't the clearest.

Yep, haste makes waste. Glad you can use it.
Regards, JLG

 

[BiocideJ]

I just want to point out that the 4th write statement is going to overwrite part of the 3rd write statement if I am reading the code correctly.

e.g.
What you copy from B5:E5 into C{row#}:F{row#}
the value in D{row#} will be overwritten when you paste the values of A63:A77 into D{row#}

 

[balla506]

Yep, BiocideJ you are correct but I will be filling in these cells with data after the first paste so it should be good. Thanks for the call out.