Copy a sheet from multiple workbooks within a folder

[slparadise]

I have about 500 workbooks that I need to analyze for trends. I need to copy "Sheet 2" from every workbook into a new workbook. Here are the steps in my mind (feel free to correct)...

Step 1: Open workbook "NEW"
Step 2: Open workbook "A" - copy sheet 2 from workbook "A" and paste into workbook "NEW" sheet 1 - Create sheet "2" in workbook "NEW" - close workbook "A"
Step 3: Open workbook "B" - copy sheet 2 from workbook "B" and paste into workbook "NEW" sheet 2 - Create sheet "3" in workbook "NEW" - close workbook "B"
Step 4: Open workbook "C" - copy sheet 2 from workbook "C" and paste into workbook "NEW" sheet 3 - Create sheet "4" in workbook "NEW" - close workbook "C"

Repeat steps until all of the sheet 2 form all of workbooks in the folder have been copied into the "NEW" workbook. I know the limit on sheets in a workbook is about 250 so I would need to use multiple workbooks to assimilate all of the data.

Any and all help is appreciated.

 

[John_w]

I need to copy "Sheet 2" from every workbook into a new workbook

Try this macro, changing the path and file spec of the input workbooks and the path and file name format of the output workbooks as required.

Public Sub Copy_Sheet_From_All_Workbooks_In_Folder2()

    Dim matchWorkbooks As String, newWorkbookNameTemplate As String
    Dim folderPath As String, fileName As String
    Dim newWorkbook As Workbook, copyFromWorkbook As Workbook
    Dim newWorkbookCount As Long
    Const MAX_SHEETS_PER_WORKBOOK = 250
   
    matchWorkbooks = "C:\folder\path\*.xlsx"                                        'path and wildcard file spec of input workbooks
    newWorkbookNameTemplate = ThisWorkbook.Path & "\New workbook <count>.xlsx"      'path and file name format of output workbooks
   
    Application.ScreenUpdating = False
   
    Set newWorkbook = Nothing
    newWorkbookCount = 0
   
    folderPath = Left(matchWorkbooks, InStrRev(matchWorkbooks, "\"))
    fileName = Dir(matchWorkbooks)
   
    While fileName <> vbNullString
   
        If Not newWorkbook Is Nothing Then
            If newWorkbook.Worksheets.Count - 1 = MAX_SHEETS_PER_WORKBOOK Then
                Application.DisplayAlerts = False
                newWorkbook.Worksheets(1).Delete
                newWorkbook.Close SaveChanges:=True, fileName:=Replace(newWorkbookNameTemplate, "<count>", newWorkbookCount)
                Application.DisplayAlerts = True
                Set newWorkbook = Nothing
            End If
        End If
       
        If newWorkbook Is Nothing Then
            Set newWorkbook = Workbooks.Add(xlWBATWorksheet)
            newWorkbook.Worksheets(1).Name = "_TEMP_"
            newWorkbookCount = newWorkbookCount + 1
        End If
       
        Set copyFromWorkbook = Workbooks.Open(folderPath & fileName)
        copyFromWorkbook.Worksheets("Sheet 2").Copy After:=newWorkbook.Worksheets(newWorkbook.Worksheets.Count)
        copyFromWorkbook.Close SaveChanges:=False
       
        fileName = Dir
        DoEvents
       
    Wend
   
    If Not newWorkbook Is Nothing Then
        Application.DisplayAlerts = False
        newWorkbook.Worksheets(1).Delete
        newWorkbook.Close SaveChanges:=True, fileName:=Replace(newWorkbookNameTemplate, "<count>", newWorkbookCount)
        Application.DisplayAlerts = True
    End If
   
    Application.ScreenUpdating = True
   
    MsgBox "Done"
   
End Sub