loop this code for all sheets

KalilMe

Board Regular
Joined
Mar 5, 2021
Messages
122
Office Version
  1. 2016
Platform
  1. Windows
hi
I have this code it just import data from the first sheet but I want bring all of the data from all sheet in file to one file and one sheet
VBA Code:
Sub GetSheets()
'Declare Variables
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String
Dim i As Long
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    'This line will need to be modified depending on location of source folder
    FolderLocation = "C:\Users\"
    
    'Set the current directory to the the folder path.
    ChDrive FolderLocation
    ChDir FolderLocation
    
    'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
    SelectedFiles = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
    
    'Create a new workbook
    Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
    strFilename = Dir(FolderLocation & "\*.xls", vbNormal)
    
        If IsArray(SelectedFiles) Then
        
        For i = LBound(SelectedFiles) To UBound(SelectedFiles)
            Set WorkbookSource = Workbooks.Open(SelectedFiles(i))
            Set WorksheetSource = WorkbookSource.Worksheets(1)
            WorksheetSource.Copy after:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
            WorkbookSource.Close False
            Next i
            
            End If

    WorkbookDestination.Worksheets(1).Delete
      
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub
may anybody guide me how add this line to the code
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
For clarification: Do you want to copy all the sheets in WorkbookSource to a single sheet in WorkbookDestination or to separate sheets in WorkbookDestination?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
Try:
VBA Code:
Sub GetSheets()
    'Declare Variables
    Dim WorkbookDestination As Workbook, WorkbookSource As Workbook, FolderLocation As String, strFilename As String, i As Long, ws As worksheeet
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    'This line will need to be modified depending on location of source folder
    FolderLocation = "C:\Users\"
    'Set the current directory to the the folder path.
    ChDrive FolderLocation
    ChDir FolderLocation
    'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
    SelectedFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
    'Create a new workbook
    Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
    strFilename = Dir(FolderLocation & "\*.xls", vbNormal)
    If IsArray(SelectedFiles) Then
        For i = LBound(SelectedFiles) To UBound(SelectedFiles)
            Set WorkbookSource = Workbooks.Open(SelectedFiles(i))
            For Each ws In Sheets
                ws.UsedRange.Copy WorkbookDestination.Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Offset(1)
            Next ws
            WorkbookSource.Close False
        Next i
    End If
    With Application
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
 

KalilMe

Board Regular
Joined
Mar 5, 2021
Messages
122
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

it gives error
error1.JPG
 

KalilMe

Board Regular
Joined
Mar 5, 2021
Messages
122
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

thanks . as you know each sheet contains the headers in row 1 but I want the headers just in row 1 without repeat the headers many time when merge all of the sheets
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
Try:
VBA Code:
Sub GetSheets()
    'Declare Variables
    Dim WorkbookDestination As Workbook, WorkbookSource As Workbook, FolderLocation As String, strFilename As String, i As Long, ws As Worksheet, x As Long
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    'This line will need to be modified depending on location of source folder
    FolderLocation = "C:\Users\"
    'Set the current directory to the the folder path.
    ChDrive FolderLocation
    ChDir FolderLocation
    'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
    SelectedFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
    'Create a new workbook
    Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
    strFilename = Dir(FolderLocation & "\*.xls", vbNormal)
    If IsArray(SelectedFiles) Then
        For i = LBound(SelectedFiles) To UBound(SelectedFiles)
            Set WorkbookSource = Workbooks.Open(SelectedFiles(i))
            For Each ws In Sheets
                If x = 0 Then
                    ws.UsedRange.Copy WorkbookDestination.Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Offset(1)
                    x = 1
                Else
                    ws.UsedRange.Offset(1).Copy WorkbookDestination.Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Offset(1)
                End If
            Next ws
            WorkbookSource.Close False
            x = 0
        Next i
    End If
    With Application
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
 

KalilMe

Board Regular
Joined
Mar 5, 2021
Messages
122
Office Version
  1. 2016
Platform
  1. Windows
great! just last thing the code creates a new workbook when run the code . I don't want that .
 

Forum statistics

Threads
1,140,921
Messages
5,703,174
Members
421,279
Latest member
emzy

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
Top