copy summary sheet from 100 reports - paste each sheet as a new sheet in a master workbook

[RachelRPL]

I am completely new to VBA. I know only enough to copy paste and make simple edits to existing code. I have some code that I have used in the past on less complicated reports. When I try to use it now, I see that it is cycling through/opening the files in the folder, and it creates the new workbook, but nothing is pasted in the new workbook.

I have approx 100 workbooks (EmployeeLastNameMonthlyReport.xlsx) ...all have different file names and the names change on a monthly basis... Each report workbook has multiple worksheets. All 100 are saved in a folder (December2017). The first worksheet in each workbook is named Summary. I need to copy all of the Summary worksheets into a new workbook so that I can easily view/compile/manipulate all monthly data. I don't want any of the formulas or references copied, only the values. The new workbook would have 100 tabs.

I have searched many sites and found answers that come close, but nothing actually solves the problem. I would be so grateful if someone would take a look for me.

Sub CopySheet1s()
' Copies first sheet from all workbooks in current path
' to a new workbook called wbOutput.xlsx


Dim fso As New Scripting.FileSystemObject
Dim vFile As Variant, sFile As String, lPos As Long
Dim wbInput As Workbook, wbOutput As Workbook
Dim fFolder As Folder
Const cOUTPUT As String = "wbOutput.xlsx"


    If fso.FileExists(cOUTPUT) Then
        fso.DeleteFile cOUTPUT
    End If


    Set wbOutput = Workbooks.Add()


    Set fFolder = fso.GetFolder(ThisWorkbook.Path)
    For Each vFile In fFolder.Files
        lPos = InStrRev(vFile, "\")
        sFile = Mid(vFile, lPos + 1)
        If sFile <> cOUTPUT And sFile <> ThisWorkbook.Name And Left(sFile, 1) <> "~" Then
            Set wbInput = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
            wbInput.Worksheets(1).Copy after:=wbOutput.Worksheets(1)
            wbInput.Close savechanges:=False
        End If
    Next


    wbOutput.SaveAs Filename:=cOUTPUT
    wbOutput.Close


End Sub

Thanks in advance for any thoughts.

 

[mumps]

Open a new workbook. Place this macro in a regular module in the new workbook and save it as a macro-enabled file. Change the folder path in the code to suit your needs. The macro assumes that only the source files are contained in the folder.

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Const strPath As String = "C:\December2017\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            wkbDest.Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Left(wkbSource.Name, 31)
            wkbSource.Sheets("Summary").Cells.Copy
            wkbDest.Sheets(Left(wkbSource.Name, 31)).Cells(1, 1).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[RachelRPL]

Thanks so much for your reply mumps. I get a Run Time Error '9' Subscript out of range. When I debug, it points to

.Sheets("Summary").Copy After:=wkbDest.Sheets(Sheets.Count)

 

[Fluff]

The line you have shown does not appear in the code that mumps supplied in post#2.
mumps did edit the post, so I'd suggest copying the code as it stands now & try again.

 

[RachelRPL]

Thank you Fluff and mumps again. I now get a Run Time error '1004' Method 'Add' of object 'Sheets' failed. Debug points to wkbDest.Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Left(wkbSource.Name, 31)

 

[Fluff]

What is the name of the workbook that you are trying to import, when that error occurs?
Also do you have workbook protection on the workbook you are running the code from?

 

[RachelRPL]

it seems to have called up the first report alphabetically which is "Aiola Monthly Report Nov 2017.xlsx"
Each of the sheets are protected but not the workbook.

 

[Fluff]

Can you manually add a sheet to the workbook, that has the macro?

 

[Fluff]

Ignore post#8 & try this

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Dim strExtension As String
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Const strPath As String = "C:\Users\DaveC\Desktop\test\Fluff\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            wkbDest.Worksheets.Add(After:=wkbDest.Sheets(wkbDest.Sheets.Count)).name = Left(.name, 31)
            .Sheets("Summary").Cells.Copy
            wkbDest.Sheets(Left(.name, 31)).Cells(1, 1).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Try unprotecting the sheet first with this version:

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Const strPath As String = "C:\December2017\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            wkbDest.Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Left(wkbSource.Name, 31)
            wkbSource.Sheets("Summary").Unprotect
            wkbSource.Sheets("Summary").Cells.Copy
            wkbDest.Sheets(Left(wkbSource.Name, 31)).Cells(1, 1).PasteSpecial xlPasteValues
            wkbSource.Sheets("Summary").Protect
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

This assumes there is no password.