VBA: Copy First Sheet of a List of Workbooks to New Workbook

Greetings,

I am trying to copy the first worksheet in a list of workbooks to a new workbook using this:

Private myFiles() As String
Private Fnum As Long

Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
                        ExtStr As String, myReturnedFiles As Variant) As Long

    Dim Fso_Obj As Object, RootFolder As Object
    Dim SubFolderInRoot As Object, file As Object

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    MsgBox MyPath
    'Create FileSystemObject object
    Set Fso_Obj = CreateObject("Scripting.FileSystemObject")

    Erase myFiles()
    Fnum = 0

    'Test if the folder exist and set RootFolder
    If Fso_Obj.FolderExists(MyPath) = False Then
        Exit Function
    End If
    Set RootFolder = Fso_Obj.GetFolder(MyPath)

    'Fill the array(myFiles)with the list of Excel files in the folder(s)
    'Loop through the files in the RootFolder
    For Each file In RootFolder.Files
        If LCase(file.Name) Like LCase(ExtStr) Then
            Fnum = Fnum + 1
            ReDim Preserve myFiles(1 To Fnum)
            myFiles(Fnum) = MyPath & file.Name
        End If
    Next file

    'Loop through the files in the Sub Folders if SubFolders = True
    If Subfolders Then
        Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
    End If

    myReturnedFiles = myFiles
    Get_File_Names = Fnum
End Function


Sub mcrAWCF_Copy_Sheet()
    Dim myFiles As Variant
    Dim myCountOfFiles As Long
    On Error GoTo Errorcatch

    myCountOfFiles = Get_File_Names( _
                     MyPath:="H:\Program Budget\AWCF\FY2012\AWCF_POM_FY14_FY18\FY14_FY18_POM_AVN_Ready", _
                     Subfolders:=False, _
                     ExtStr:="*.xlsx", _
                     myReturnedFiles:=myFiles)
'    MsgBox myCountOfFiles
    If myCountOfFiles = 0 Then
        MsgBox "No files that match the ExtStr in this folder"
        Exit Sub
    End If

    Get_Sheet _
            PasteAsValues:=True, _
            SourceShName:="", _
            SourceShIndex:=1, _
            myReturnedFiles:=myFiles
            
    Exit Sub

Errorcatch:
    MsgBox Err.Description


End Sub

Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _
              SourceShIndex As Integer, myReturnedFiles As Variant)
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim CalcMode As Long
    Dim SourceSh As Variant
    Dim sh As Worksheet
    Dim I As Long

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    On Error GoTo ExitTheSub

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    'set basewks = workbooks.Add(

    'Check if we use a named sheet or the index
    If SourceShName = "" Then
        SourceSh = SourceShIndex
    Else
        SourceSh = SourceShName
    End If

    'Loop through all files in the array(myFiles)
    For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(myReturnedFiles(I))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            'Set sh and check if it is a valid
            On Error Resume Next
            Set sh = mybook.Sheets(SourceSh)

            If Err.Number > 0 Then
                Err.Clear
                Set sh = Nothing
            End If
            On Error GoTo 0

            If Not sh Is Nothing Then
                sh.Copy after:=BaseWks.Parent.Sheets(BaseWks.Parent.Sheets.Count)

                On Error Resume Next
                ActiveSheet.Name = mybook.Name
                On Error GoTo 0

                If PasteAsValues = True Then
                    With ActiveSheet.UsedRange
                        .Value = .Value
                    End With
                End If

            End If
            'Close the workbook without saving
            mybook.Close savechanges:=False
        End If

        'Open the next workbook
    Next I
    MsgBox I
    
    ' delete the first sheet in the workbook
    Application.DisplayAlerts = False
    On Error Resume Next
    BaseWks.Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

I've assigned the macro 'mcrAWCF_Copy_Sheet()' to a button, when I hit the button, I first got the very explanatory '400' error, then I inserted some error code to get a description of the error, and got an
elaborate message in a 'Microsoft Excel" message box that stated: "Excel cannot insert the sheet into the destination workbook because it contains fewer rows and columns than the source workbook. To move or copy the data to the destination workbook, you can select the data, and then use the Copy and Paste command to insert it into the sheets of another workbook." Now, I can do all the cutting and pasting manually, but I was trying to make it easy because there are 27 files to process. I know it gets to the "Get_File_Names" Function because I put a message box in there to see if it made it. Does anyone see anything that leaps out at them as the obvious error? I have been looking at this code for too long I think and cannot for the life of me find what is wrong. It looks like it should work but it doesn't. Any and/or all assistance would be greatly appreciated.

Originally Posted by arlu1201

Are any of your files in excel 2003?

No, they are all in excel 2007 format.

Originally Posted by Domski

If you just want to copy the first sheet from all the files in a folder into a new workbook this should do the trick:

Sub LoopFiles()

    Dim strDir As String, strFileName As String
    Dim wbCopyBook As Workbook
    Dim wbNewBook As Workbook

    strDir = "C:\"
    strFileName = Dir(strDir & "*.xlsx")

    Set wbNewBook = Workbooks.Add

    Do While strFileName <> ""
        Set wbCopyBook = Workbooks.Open(strDir & strFileName)
        wbCopyBook.Sheets(1).Copy Before:=wbNewBook.Sheets(1)
        wbCopyBook.Close False
        strFileName = Dir
    Loop

End Sub

Dom

Thanks, I tried this and got Run-Time error '1004', with the same detailed error message......not sure what to do now...

Originally Posted by Domski

No idea. Code runs fine for me. You must have something else causing the error.

Can you upload your workbook?

Dom

Sure, how do I do that? lol...Sorry, a newb to this board....

Ok,

I have attached a sample copy of one of the workbooks, they all start with the same page, and it is named "Org. Req. Roll-Up", and this is the worksheet I am trying to retrieve from each workbook in the folder ( there are 27 different workbooks).

I hope this will help and thank you all who are helping me, I really do appreciate this.

Hi!

Thanks for this thread, the code is working fine!

Is there any chance to copy all sheets of all files, instead only the first sheet?