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

RachelRPL

New Member
Joined
Dec 15, 2017
Messages
7
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.

Code:
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.
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
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.
Code:
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
 
Last edited:
Upvote 0
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)
 
Upvote 0
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.
 
Upvote 0
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)
 
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
Can you manually add a sheet to the workbook, that has the macro?
 
Upvote 0
Ignore post#8 & try this
Code:
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
 
Upvote 0
Try unprotecting the sheet first with this version:
Code:
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.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,034
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top