Merge Single tab from multiple spreadsheets

[treznorse]

Hello - I have researched past threads to try to find an answer to this, but nothing fits exactly what I'm trying to do.

My goal is to merge a single tab from up to 140 different workbooks into a single tab in a new workbook. The number of columns of data to be copied is identical in each of the 140 tabs, but the number of rows varies. If possible, I would only like to copy the first row from each of these only once. I'm trying to create a rolling list of data without repeating the column header 140 times.

Any help is appreciated.

Thank you!

 

[Domenic]

Assumptions:

1) All relevant files are located in a single folder.

2) The source worksheet for each opened file is the active sheet.

3) The destination worksheet is the active sheet.

Macro:

[font=Verdana][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] MergeFiles()

    [color=darkblue]Dim[/color] strPath [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] strFile [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] wkbSource [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] wksSource [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] wksDest [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] SourceRng [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] SourceRowCount [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] LastColumn [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] NextRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] Cnt [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] CalcMode [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]With[/color] Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = [color=darkblue]False[/color]
        .EnableEvents = [color=darkblue]False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]Set[/color] wksDest = ActiveWorkbook.ActiveSheet
    
    [color=green]'Chang the path accordingly[/color]
    strPath = "C:\Users\Domenic\Desktop\Test\"
    
    [color=darkblue]If[/color] Right(strPath, 1) <> "\" [color=darkblue]Then[/color] strPath = strPath & "\"
    
    strFile = Dir(strPath & "*.xls")
    
    NextRow = 2
    [color=darkblue]Do[/color] [color=darkblue]While[/color] Len(strFile) > 0
        Cnt = Cnt + 1
        [color=darkblue]Set[/color] wkbSource = Workbooks.Open(strPath & strFile)
        [color=darkblue]Set[/color] wksSource = wkbSource.ActiveSheet
        [color=darkblue]With[/color] wksSource
            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
            [color=darkblue]Set[/color] SourceRng = Range(.Cells(2, 1), .Cells(LastRow, LastColumn))
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        SourceRowCount = SourceRng.Rows.Count
        [color=darkblue]If[/color] NextRow + SourceRowCount - 1 > wksDest.Rows.Count [color=darkblue]Then[/color]
            MsgBox "There are not enough rows in the worksheet...", vbExclamation
            [color=darkblue]GoTo[/color] ExitSub
        [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]With[/color] wksSource
            [color=darkblue]If[/color] Cnt = 1 [color=darkblue]Then[/color]
                .Range(.Cells(1, 1), .Cells(1, LastColumn)).Copy wksDest.Range("A1")
                SourceRng.Copy wksDest.Range("A2")
            [color=darkblue]Else[/color]
                SourceRng.Copy wksDest.Cells(NextRow, "A")
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]End[/color] [color=darkblue]With[/color]
        NextRow = NextRow + SourceRowCount
        wkbSource.Close savechanges:=[color=darkblue]False[/color]
        strFile = Dir
    [color=darkblue]Loop[/color]

    Columns.AutoFit

ExitSub:

    [color=darkblue]With[/color] Application
        .Calculation = CalcMode
        .ScreenUpdating = [color=darkblue]True[/color]
        .EnableEvents = [color=darkblue]True[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
[/font]

If the source worksheet for each opened file is the first worksheet, replace...

[font=Verdana][color=darkblue]Set[/color] wksSource = wkbSource.ActiveSheet[/font]

with

[font=Verdana][color=darkblue]Set[/color] wksSource = wkbSource.Worksheets(1)[/font]

If the source worksheet for each opened file is a specific sheet, such as Sheet1, replace...

[font=Verdana][color=darkblue]Set[/color] wksSource = wkbSource.ActiveSheet[/font]

with

[font=Verdana][color=darkblue]Set[/color] wksSource = wkbSource.Worksheets("Sheet1")[/font]