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.

 

[RachelRPL]

Yes I can manually add a sheet in the blank workbook. I moved the macro into one of the monthly reports and it works from there. Not sure why it wouldn't work in a blank workbook? I don't really care as I am excited to not have to open and copy 100 files/worksheets.

Excel tells me there is a lot of information on the clipboard... do you want to be able to paste this information later... everytime it copies a worksheet. Is there any way around having to answer "no" for every time it copies a worksheet?

 

[Fluff]

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.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

This will remove the warning & should also work in a blank workbook.
The reason for the problems, was that the macro was counting the number of sheet in the "Aiola Monthly Report Nov 2017.xlsx" file (lets say 5) & than trying to add a new sheet in the blank workbook after sheet 5, which you can't do if there is only 1 sheet.

 

[RachelRPL]

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.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

This will remove the warning & should also work in a blank workbook.
The reason for the problems, was that the macro was counting the number of sheet in the "Aiola Monthly Report Nov 2017.xlsx" file (lets say 5) & than trying to add a new sheet in the blank workbook after sheet 5, which you can't do if there is only 1 sheet.

Great! This one works even from a blank workbook! It doesn't ignore the "clipboard" error, though. Thank you so very much!

 

[Fluff]

Oops, put it in the wrong place.

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
            [COLOR=#0000ff]Application.CutCopyMode = False[/COLOR]
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[RachelRPL]

Fluff- I can't say thanks enough! It is perfect. Thanks a million.

 

[Fluff]

Glad we could help & thanks for the feedback