Thread: Import content from separate Excel files to a single spreadsheet?

Hehe, yep, significantly different. OK. So the visible columns to import are F,M,N and O. We need to check EACH column and use the column with the deepest value for the LR variable.

We need to do the same thing on the import sheet, too.

Try these changes, updates marked in red:

Option Explicit

Sub Consolidate()
'Author:     JBeaucaire'
'Date:       2/11/2010     (2007 compatible)'
'Summary:    Open all Excel files in a specific folder and merge data'
'            into one master sheet (stacked)'
'            Moves imported files into another folder'
Dim fName As String, fPath As String, fPathDone As String, OldDir As String
Dim LR As Long, NR As Long
Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet, wsNew As Worksheet

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Set wsNew = wbkNew.Sheets("Sheet1")
    wsNew.Activate   'sheet report is built into, edit as needed
    
    If MsgBox("Import new data to this report?", vbYesNo) = vbNo Then Exit Sub
    
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        Cells.Clear
        NR = 1
    Else
        NR = Range("A" & Rows.Count).End(xlUp).Row + 1
    End If

'Path and filename
    OldDir = CurDir                         'memorizes your current working path
    fPath = "C:\Project1\"                  'files are here
    fPathDone = "C:\Project1\Imported\"      'move files to here after import
    ChDir fPath
    fName = Dir("*.xls")                    'filtering key, change to suit

'Import a sheet from found file
    Do While Len(fName) > 0
        Set wbkOld = Workbooks.Open(fName)      'Open file
            For Each ws In ActiveWorkbook.Worksheets
                With wsNew
                    .Range("A" & NR).Value = fName
                    .Range("B" & NR) = "Worksheet: " & ws.Name
                    .Range("A" & NR, "D" & NR).Interior.ColorIndex = 43
                    LR = Application.WorksheetFunction.Max( _
                        ws.Range("F" & Rows.Count).End(xlUp).Row, _
                            ws.Range("M" & Rows.Count).End(xlUp).Row, _
                                ws.Range("N" & Rows.Count).End(xlUp).Row, _
                                    ws.Range("O" & Rows.Count).End(xlUp).Row)   'Find last row and copy data edit range to suit
                    ws.Range("F2:O" & LR).SpecialCells(xlCellTypeVisible).Copy
                    .Range("A" & NR + 1).PasteSpecial xlPasteAll
                    NR = Application.WorksheetFunction.Max( _
                        .Range("A" & .Rows.Count).End(xlUp).Row, _
                            .Range("B" & .Rows.Count).End(xlUp).Row, _
                                .Range("C" & .Rows.Count).End(xlUp).Row, _
                                    .Range("D" & .Rows.Count).End(xlUp).Row) + 1   'Next row
                    End With
            Next ws
        wbkOld.Close False   'close file
        Name fPath & fName As fPathDone & fName     'move file to "imported" folder
        fName = Dir     'ready next filename
    Loop

'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    ChDir OldDir    'restores your original working path
End Sub

Try this:

Option Explicit

Sub Consolidate()
'Author:     JBeaucaire'
'Date:       2/11/2010     (2007 compatible)'
'Summary:    Open all Excel files in a specific folder and merge data'
'            into one master sheet (stacked)'
'            Moves imported files into another folder'
Dim fName As String, fPath As String, fPathDone As String, OldDir As String
Dim LR As Long, NR As Long
Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet, wsNew As Worksheet

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Set wsNew = wbkNew.Sheets("Sheet1")
    wsNew.Activate   'sheet report is built into, edit as needed
    
    If MsgBox("Import new data to this report?", vbYesNo) = vbNo Then Exit Sub
    
    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        Cells.clear
        NR = 1
    Else
        NR = Range("A" & Rows.Count).End(xlUp).Row + 1
    End If

'Path and filename
    OldDir = CurDir                         'memorizes your current working path
    fPath = "C:\Project1\"                  'files are here
    fPathDone = "C:\Project1\Imported\"      'move files to here after import
    ChDir fPath
    fName = Dir("*.xls")                    'filtering key, change to suit

'Import a sheet from found file
    Do While Len(fName) > 0
        Set wbkOld = Workbooks.Open(fName)      'Open file
            For Each ws In ActiveWorkbook.Worksheets
                With wsNew
                    .Range("A" & NR).Value = fName
                    .Range("B" & NR) = "Worksheet: " & ws.Name
                    LR = Application.WorksheetFunction.Max( _
                        ws.Range("F" & Rows.Count).End(xlUp).Row, _
                            ws.Range("M" & Rows.Count).End(xlUp).Row, _
                                ws.Range("N" & Rows.Count).End(xlUp).Row, _
                                    ws.Range("O" & Rows.Count).End(xlUp).Row)   'Find last row and copy data edit range to suit
                    ws.Range("F2:O" & LR).SpecialCells(xlCellTypeVisible).Copy
                    .Range("C" & NR).PasteSpecial xlPasteAll
                    LR = NR
                    NR = Application.WorksheetFunction.Max( _
                        .Range("A" & .Rows.Count).End(xlUp).Row, _
                            .Range("B" & .Rows.Count).End(xlUp).Row, _
                                .Range("C" & .Rows.Count).End(xlUp).Row, _
                                    .Range("D" & .Rows.Count).End(xlUp).Row) + 1   'Next row
                    .Range("A" & LR, "B" & LR).AutoFill .Range("A" & LR, "B" & NR - 1)
                    End With
            Next ws
        wbkOld.Close False   'close file
        Name fPath & fName As fPathDone & fName     'move file to "imported" folder
        fName = Dir     'ready next filename
    Loop

'Cleanup
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    ChDir OldDir    'restores your original working path
End Sub

Try this:

.Range("A" & LR, "B" & LR).Copy .Range("A" & LR + 1, "B" & NR - 1)