excel vba for open, copy multiple workbooks then paste all in a new workbook sheet1

J

jhae

New Member
Joined
May 11, 2011
Messages
6
Hi can somebody please help me create macro for I want to open multiple workbooks (all are save in the same folder), copy all data from sheet1 of each workbook and paste it in a new workbook. On the new workbook sheet1, data of workbook1 will be paste then on its last row follows data of workbook2 and so on. After copying all data all workbook must be closed except the new workbook and the workbook that contains the macro. :confused:
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Sort by date Sort by votes
Welcome to the Board!

The last filled cell in Column A on each Sheet1 defines the last row to be copied from that sheet.

If any of the source workbooks have macros you must answer each Enable/Disable question with Enable, or this code will stop. If you don't know what that code is doing, you should not run iopen that workbook.

Code: 
Option Explicit
 
Sub CopySheeet1FromAllExcelFilesInThisFilesDirectory()
    'Note last row of data in each Sheet1 is presumed to be the
    'last row of Column A with data in it.
 
    Dim strFileDirectory As String
    Dim strFileName As String
    Dim iAnswer As Integer
    Dim intFileCount As Integer
    Dim lNextWriteRow As Long
    Dim sError As String
    Dim sReport As String
    Dim lX As Long
    Dim bFound As Boolean
    Dim lLastDataRow As Long
    Dim iVisibleWindows As Integer
    Dim sPreface As String
 
    'This workbook saved?
    If ThisWorkbook.Path = "" Then
        MsgBox "Save this file in the desired directory before continuing"
        GoTo End_Sub
    End If
 
    For lX = 1 To Sheets.Count
        If Worksheets(lX).Name = "Sheet1" Then
            bFound = True
            Exit For
        End If
        If Not bFound Then Worksheets.Add(before:=Sheets(1)).Name = "Sheet1"
    Next
 
    'Close other workbooks - they may be ones we want to process
    'and we don't want to overwrite them.
    If Windows.Count > 1 Then
        iAnswer = MsgBox("Close other workbooks and continue?" & vbCrLf & _
            "   OK     to close all other workbooks and continue, or" & vbCrLf & _
            "   Cancel to stop this macro.", vbOKCancel + _
            vbDefaultButton2 + vbExclamation, "Continue ?")
    End If
    If iAnswer = vbCancel Then
        GoTo End_Sub
    Else
        iVisibleWindows = Windows.Count
        For lX = Windows.Count To 1 Step -1
            If Windows(lX).Caption <> ThisWorkbook.Name Then
                If Windows(lX).Visible Then
                'if workbook modified user will get
                'chance to save or cancel for each
                    Windows(lX).Close
                Else
                    iVisibleWindows = iVisibleWindows - 1
                End If
            End If
        Next
    End If
 
    strFileDirectory = ThisWorkbook.Path & "\"
    'See if user chose Cancel for any close requests
    If iVisibleWindows > 1 Then
        MsgBox "Other Excel workbooks are still open. " & _
            "Close other workbooks and try again", , "Process Cancelled."
        GoTo End_Sub
    End If
 
    'More than this .xls file in the directory?
    strFileName = Dir(strFileDirectory & "*.xls", 1)
    Do While strFileName <> ""
        intFileCount = intFileCount + 1
        strFileName = Dir
    Loop
    If intFileCount = 1 Then
        MsgBox "There are no other Excel files in the specified directory: " & vbCrLf & _
            "   " & strFileDirectory & vbCrLf & _
            "There is nothing to process.", , "No Excel Files"
        GoTo End_Sub
    End If
 
    iAnswer = MsgBox("All data on Sheet1 will be deleted.  Continue?", vbOKCancel, "Clear Sheet1?")
    If iAnswer = vbOK Then
 
        MsgBox "DO NOT ENABLE MACROS IN ANY FILE THAT YOU ARE UNSURE OF" & vbLf & vbLf & _
            "If you are prompted to enable macros for any file then you must do so for this process to complete." & vbLf & vbLf & _
            "DO NOT ENABLE MACROS IN ANY FILE THAT YOU ARE UNSURE OF"
        ThisWorkbook.Worksheets("Sheet1").UsedRange.Clear
        lNextWriteRow = 1
        'Process other workbooks
        strFileName = Dir(strFileDirectory & "*.xls?", 1)
        Do While strFileName <> ""
            If UCase(strFileName) <> UCase(ThisWorkbook.Name) And _
                UCase(strFileName) <> "PERSONAL.XLS" And _
                strFileName <> "PERSONAL.XLSM" Then
                bFound = False
                 Workbooks.Open Filename:=strFileDirectory & strFileName
 
                'Process file
                For lX = 1 To Worksheets.Count
                    If Worksheets(lX).Name = "Sheet1" Then
                        bFound = True
                        Exit For
                    End If
                Next
                If bFound Then
                    lLastDataRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
                    Worksheets("Sheet1").Rows("1:" & lLastDataRow).Copy Destination:=ThisWorkbook.Sheets("Sheet1").Cells(lNextWriteRow, 1)
                    sReport = sReport & vbLf & lLastDataRow & vbTab & ActiveWorkbook.Name
                Else
                    sError = sError & vbLf & ActiveWorkbook.Name
                End If
 
                ActiveWorkbook.Saved = True
                Windows(strFileName).Close
            End If
            strFileName = Dir
            lNextWriteRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
 
        Loop
 
        sPreface = "For directory: " & ThisWorkbook.Path & vbLf & vbLf
        If sReport = "" Then sReport = "<NONE>"
        If sError <> "" Then sReport = sReport & vbLf & vbLf & _
            "The following workbooks did not contain a worksheet named 'Sheet1':" & vbLf
        MsgBox sPreface & "Rows" & vbTab & "Copied from 'Sheet1'" & vbLf & "1 thru" & vbTab & " in each of these workbooks:" & vbLf & _
            sReport & sError
        Sheets("Sheet1").Copy
        ThisWorkbook.Worksheets("Sheet1").UsedRange.Clear
    Else
        MsgBox "Process Cancelled"
    End If
End_Sub:
End Sub
 
Last edited:
Upvote 0
Hi there Sir Phil! I wonder if there's a way to include the total number of rows copied (sum for all workbooks)??
 
Last edited:
Upvote 0
With requested changes (and a couple of errors corrected):
Code: 
Option Explicit
 
Sub CopySheeet1FromAllExcelFilesInThisFilesDirectory()
    'Note last row of data in each Sheet1 is presumed to be the
    'last row of Column A with data in it.
 
    Dim strFileDirectory As String
    Dim strFileName As String
    Dim iAnswer As Integer
    Dim intFileCount As Integer
    Dim lNextWriteRow As Long
    Dim sError As String
    Dim sReport As String
    Dim lX As Long
    Dim bFound As Boolean
    Dim lLastDataRow As Long
    Dim iVisibleWindows As Integer
    Dim sPreface As String
    Dim lNextSummaryWriteRow As Long
    Dim lLinesCopied As Long
 
    'This workbook saved?
    If ThisWorkbook.Path = "" Then
        MsgBox "Save this file in the desired directory before continuing"
        GoTo End_Sub
    End If
 
    For lX = 1 To Sheets.Count
        If Worksheets(lX).Name = "Sheet1" Then
            bFound = True
            Exit For
        End If
    Next
    If Not bFound Then Worksheets.Add(before:=Sheets(1)).Name = "Sheet1"
 
    bFound = False
    For lX = 1 To Sheets.Count
        If Worksheets(lX).Name = "Summary" Then
            bFound = True
            Exit For
        End If
    Next
    If Not bFound Then Worksheets.Add(after:=Sheets("Sheet1")).Name = "Summary"
 
    'Close other workbooks - they may be ones we want to process
    'and we don't want to overwrite them.
    If Windows.Count > 1 Then
        iAnswer = MsgBox("Close other workbooks and continue?" & vbCrLf & _
            "   OK     to close all other workbooks and continue, or" & vbCrLf & _
            "   Cancel to stop this macro.", vbOKCancel + _
            vbDefaultButton2 + vbExclamation, "Continue ?")
    End If
    If iAnswer = vbCancel Then
        GoTo End_Sub
    Else
        iVisibleWindows = Windows.Count
        For lX = Windows.Count To 1 Step -1
            If Windows(lX).Caption <> ThisWorkbook.Name Then
                If Windows(lX).Visible Then
                'if workbook modified user will get
                'chance to save or cancel for each
                    Windows(lX).Close
                End If
                iVisibleWindows = iVisibleWindows - 1
            End If
        Next
    End If
 
    strFileDirectory = ThisWorkbook.Path & "\"
    'See if user chose Cancel for any close requests
    If iVisibleWindows > 1 Then
        MsgBox "Other Excel workbooks are still open. " & _
            "Close other workbooks and try again", , "Process Cancelled."
        GoTo End_Sub
    End If
 
    'More than this .xls file in the directory?
    strFileName = Dir(strFileDirectory & "*.xls", 1)
    Do While strFileName <> ""
        intFileCount = intFileCount + 1
        strFileName = Dir
    Loop
    If intFileCount = 1 Then
        MsgBox "There are no other Excel files in the specified directory: " & vbCrLf & _
            "   " & strFileDirectory & vbCrLf & _
            "There is nothing to process.", , "No Excel Files"
        GoTo End_Sub
    End If
 
    iAnswer = MsgBox("All data on worksheets: 'Sheet1' and 'Summary' will be deleted.  Continue?", vbOKCancel, "Clear Sheet1?")
    If iAnswer = vbOK Then
 
        MsgBox "DO NOT ENABLE MACROS IN ANY FILE THAT YOU ARE UNSURE OF" & vbLf & vbLf & _
            "If you are prompted to enable macros for any file then you must do so for this process to complete." & vbLf & vbLf & _
            "DO NOT ENABLE MACROS IN ANY FILE THAT YOU ARE UNSURE OF"
            
        With ThisWorkbook.Worksheets("Sheet1")
            .UsedRange.Clear
            For lX = .Shapes.Count To 1 Step -1
                .Shapes(lX).Delete
            Next
        End With
        ThisWorkbook.Worksheets("Summary").UsedRange.Clear
        
        lNextWriteRow = 1
        lNextSummaryWriteRow = 2
        Worksheets("Summary").Range("A1").Resize(1, 4).Value = Array("WorkBook Copied", "# Lines", "", "Total Lines Copied")
        
        'Process other workbooks
        strFileName = Dir(strFileDirectory & "*.xls?", 1)
        Do While strFileName <> ""
            If UCase(strFileName) <> UCase(ThisWorkbook.Name) And _
                UCase(strFileName) <> "PERSONAL.XLS" And _
                strFileName <> "PERSONAL.XLSM" Then
                bFound = False
                 Workbooks.Open Filename:=strFileDirectory & strFileName
 
                'Process file
                For lX = 1 To Worksheets.Count
                    If Worksheets(lX).Name = "Sheet1" Then
                        bFound = True
                        Exit For
                    End If
                Next
                If bFound Then
                    Worksheets("sheet1").Activate
                    Range("A1").Select 'in case workbook was saved with an object selected
                    lLastDataRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
                    Worksheets("Sheet1").Rows("1:" & lLastDataRow).Copy Destination:=ThisWorkbook.Sheets("Sheet1").Cells(lNextWriteRow, 1)
                    sReport = sReport & vbLf & lLastDataRow & vbTab & ActiveWorkbook.Name
                    ThisWorkbook.Worksheets("Summary").Cells(lNextSummaryWriteRow, 1) = strFileName
                    ThisWorkbook.Worksheets("Summary").Cells(lNextSummaryWriteRow, 2) = lLastDataRow
                    lNextSummaryWriteRow = lNextSummaryWriteRow + 1
                    lLinesCopied = lLinesCopied + lLastDataRow
                Else
                    sError = sError & vbLf & ActiveWorkbook.Name
                End If
 
                ActiveWorkbook.Saved = True
                Windows(strFileName).Close
            End If
            strFileName = Dir
            lNextWriteRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
            With ThisWorkbook.Worksheets("Summary")
                .Columns("A:D").EntireColumn.AutoFit
                .Range("A1").Activate
            End With
            
        Loop
        
        ThisWorkbook.Worksheets("Summary").Cells(2, 4) = lLinesCopied
 
        sPreface = "For directory: " & ThisWorkbook.Path & vbLf & vbLf
        If sReport <> "" Then sReport = sReport & vbLf & "------" & vbLf & _
            lLinesCopied & vbTab & "Total Lines Copied"
        If sError <> "" Then sReport = sReport & vbLf & vbLf & _
            "The following workbooks did not contain a worksheet named 'Sheet1':" & vbLf
        MsgBox sPreface & "Rows" & vbTab & "Copied from 'Sheet1'" & vbLf & "1 thru" & vbTab & " in each of these workbooks:" & vbLf & _
            sReport & sError
        Sheets("Sheet1").Copy
        With ThisWorkbook.Worksheets("Sheet1")
            .UsedRange.Clear
            For lX = .Shapes.Count To 1 Step -1
                .Shapes(lX).Delete
            Next
        End With
    Else
        MsgBox "Process Cancelled"
    End If
End_Sub:
End Sub
 
Upvote 0
i have similar problem.
this macro works great for me except in one part - i do have so many sheets in the specific folder which names are not "Sheet1", it is in each worksheets different Sheets name, but desirable sheets range is the same.

i was wondering what this modified macro would be if it is applied and one more thing. to split data in Summary sheet in column "WorkBook Copied" into workbook and worksheet name
thx
 
Last edited:
Upvote 0
So you would like every worksheet in every workbook in a specified directory copied to a single worksheet?
 
Upvote 0
Application.AutomationSecurity lines commented out. Still testing with them.
Code: 
Option Explicit
 
Sub CopyAllWorksheeetsFromAllExcelFilesInThisFilesDirectory()
    'Note last row of data in each worksheet is presumed to be the
    'last row of Column A with data in it.
 
    Dim strFileDirectory As String
    Dim strFileName As String
    Dim strWorksheetName As String
    Dim iAnswer As Integer
    Dim intFileCount As Integer
    Dim lNextWriteRow As Long
    Dim sError As String
    Dim sReport As String
    Dim lX As Long
    Dim bFound As Boolean
    Dim lLastDataRow As Long
    Dim iVisibleWindows As Integer
    Dim sPreface As String
    Dim lNextSummaryWriteRow As Long
    Dim lLinesCopied As Long
    Dim secAutomation As MsoAutomationSecurity

    secAutomation = Application.AutomationSecurity
    
    'This workbook saved?
    If ThisWorkbook.Path = "" Then
        MsgBox "Save this file in the desired directory before continuing"
        GoTo End_Sub
    End If
 
    For lX = 1 To Sheets.Count
        If Worksheets(lX).Name = "Sheet1" Then
            bFound = True
            Exit For
        End If
    Next
    If Not bFound Then Worksheets.Add(before:=Sheets(1)).Name = "Sheet1"
 
    bFound = False
    For lX = 1 To Sheets.Count
        If Worksheets(lX).Name = "Summary" Then
            bFound = True
            Exit For
        End If
    Next
    If Not bFound Then Worksheets.Add(after:=Sheets("Sheet1")).Name = "Summary"
 
    'Close other workbooks - they may be ones we want to process
    'and we don't want to overwrite them.
    If Windows.Count > 1 Then
        iAnswer = MsgBox("Close other workbooks and continue?" & vbCrLf & _
            "   OK     to close all other workbooks and continue, or" & vbCrLf & _
            "   Cancel to stop this macro.", vbOKCancel + _
            vbDefaultButton2 + vbExclamation, "Continue ?")
    End If
    If iAnswer = vbCancel Then
        GoTo End_Sub
    Else
        iVisibleWindows = Windows.Count
        For lX = Windows.Count To 1 Step -1
            If Windows(lX).Caption <> ThisWorkbook.Name Then
                If Windows(lX).Visible Then
                'if workbook modified user will get
                'chance to save or cancel for each
                    Windows(lX).Close
                End If
                iVisibleWindows = iVisibleWindows - 1
            End If
        Next
    End If
 
    strFileDirectory = ThisWorkbook.Path & "\"
    'See if user chose Cancel for any close requests
    If iVisibleWindows > 1 Then
        MsgBox "Other Excel workbooks are still open. " & _
            "Close other workbooks and try again", , "Process Cancelled."
        GoTo End_Sub
    End If
 
    'More than this .xls? file in the directory?
    strFileName = Dir(strFileDirectory & "*.xls?", 1)
    Do While strFileName <> ""
        intFileCount = intFileCount + 1
        strFileName = Dir
    Loop
    If intFileCount = 1 Then
        MsgBox "There are no other Excel files in the specified directory: " & vbCrLf & _
            "   " & strFileDirectory & vbCrLf & _
            "There is nothing to process.", , "No Excel Files"
        GoTo End_Sub
    End If
 
    iAnswer = MsgBox("All data on worksheets: 'Sheet1' and 'Summary' will be deleted.  Continue?", vbOKCancel, "Clear Sheet1?")
    If iAnswer = vbOK Then
 
        With ThisWorkbook.Worksheets("Sheet1")
            .UsedRange.Clear
            For lX = .Shapes.Count To 1 Step -1
                .Shapes(lX).Delete
            Next
        End With
        ThisWorkbook.Worksheets("Summary").UsedRange.Clear
        
        lNextWriteRow = 1
        lNextSummaryWriteRow = 2
        Worksheets("Summary").Range("A1").Resize(1, 4).Value = Array("Workbook Copied", "Worksheet Copied", "# Lines", "", "Total Lines Copied")
        
        'Process other workbooks
        strFileName = Dir(strFileDirectory & "*.xls?", 1)
        Do While strFileName <> ""
            If UCase(strFileName) <> UCase(ThisWorkbook.Name) And _
                UCase(strFileName) <> "PERSONAL.XLS" And _
                strFileName <> "PERSONAL.XLSM" Then
                
                'Code won't run on newly opened files
                'Application.AutomationSecurity = msoAutomationSecurityForceDisable
                Workbooks.Open Filename:=strFileDirectory & strFileName, ReadOnly:=True, corruptload:=True, UpdateLinks:=False
                'Application.AutomationSecurity = secAutomation 'restore original macro security
                 
                'Process file
                For lX = 1 To Worksheets.Count
                    Worksheets(lX).Activate
                    strWorksheetName = Worksheets(lX).Name
                    Range("A1").Select 'in case workbook was saved with an object selected
                    lLastDataRow = Cells(Rows.Count, 1).End(xlUp).Row
                    If lLastDataRow + lNextWriteRow > Rows.Count Then
                        MsgBox "Next save would fill the worksheet.  Quitting."
                        GoTo End_Sub
                    End If
                    Application.StatusBar = "Processing " & strFileName & ", " & strWorksheetName
                    If Range("A1") <> "" Or lLastDataRow > 1 Then
                        Worksheets(lX).Rows("1:" & lLastDataRow).Copy Destination:=ThisWorkbook.Sheets("Sheet1").Cells(lNextWriteRow, 1)
                        sReport = sReport & vbLf & lLastDataRow & vbTab & ActiveWorkbook.Name
                        ThisWorkbook.Worksheets("Summary").Cells(lNextSummaryWriteRow, 1) = strFileName
                        ThisWorkbook.Worksheets("Summary").Cells(lNextSummaryWriteRow, 2) = strWorksheetName
                        ThisWorkbook.Worksheets("Summary").Cells(lNextSummaryWriteRow, 3) = lLastDataRow
                        lNextSummaryWriteRow = lNextSummaryWriteRow + 1
                        lLinesCopied = lLinesCopied + lLastDataRow
                    End If
                    
                    lNextWriteRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
                Next
                'Finished with opened workbook
                ActiveWorkbook.Saved = True
                Windows(strFileName).Close
            End If
            
            strFileName = Dir
        
        Loop
        
        ThisWorkbook.Worksheets("Summary").Cells(2, 4) = lLinesCopied
 
        ThisWorkbook.Activate
        Worksheets("Summary").Select
        Columns("A:D").EntireColumn.AutoFit
        Range("A1").Activate
        
        sPreface = "For directory: " & ThisWorkbook.Path & vbLf & vbLf
        If sReport <> "" Then sReport = sReport & vbLf & "------" & vbLf & _
            lLinesCopied & vbTab & "Total Lines Copied"
        If sError <> "" Then sReport = sReport & vbLf & vbLf & _
            "The following workbooks did not contain a worksheet named 'Sheet1':" & vbLf
        MsgBox sPreface & "Rows" & vbTab & "Copied from 'Sheet1'" & vbLf & "1 thru" & vbTab & " in each of these workbooks:" & vbLf & _
            sReport & sError
            
        
        Sheets("Sheet1").Copy 'Copy Sheet1 to new workbook
        
        'Clear Sheet1 in this workbook
        With ThisWorkbook.Worksheets("Sheet1")
            .UsedRange.Clear
            For lX = .Shapes.Count To 1 Step -1
                .Shapes(lX).Delete
            Next
        End With
    Else
        MsgBox "Process Cancelled"
    End If
    
End_Sub:

    Application.AutomationSecurity = secAutomation 'restore original macro security
    Application.StatusBar = False

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Macro to open multiple workbooks and copy a range of data based on todays date. Then paste the data in master workbook in one sheet under each other.
Replies
8
Views
632
Luke1690
L
L
  • Question Question
Moving and renaming multiple workbooks from a master workbook.
Replies
1
Views
266
Luke1690
L
A
  • Question Question
Open, Copy data and Close a workbook based on the names of the tabs in my active workbook
Replies
2
Views
93
Aurore87
A
B
  • Question Question
Copy and paste from one worksheet into a new workbook and save to a particular directory
Replies
3
Views
707
Joe4
Joe4
S
  • Question Question
combining data from multiple workbooks with the same sheet name into a new workbook
Replies
3
Views
463
rlv01
R

Forum statistics

Threads
1,224,520
Messages
6,179,270
Members
452,902
Latest member
Knuddeluff

Share this page

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