Importing multiple worksheets I use the following code to import multiple worksheets from another workbook and do some processing. The importing time is too long. Can anyone suggest a more efficient way to import? Should I be looking into more information in the source files for copy? Can anyone please suggest a way to speed up the import function?

I am not a professional developer, so I might have left out some key points to note. Please let me know if I need to look into something else, as well.

Sub SKR_Import()
On Error GoTo errorhandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sht As Worksheet
Set wb1 = ActiveWorkbook
Dim fd As FileDialog
Dim filechosen As Integer
Dim filename As String
Dim i As Long
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.AllowMultiSelect = True
fd.Title = "Select Excel workbooks to import all sheets"
filechosen = fd.Show
If filechosen = -1 Then
    For i = 1 To fd.SelectedItems.Count
        Set wb2 = Workbooks.Open(fd.SelectedItems(i))
        For Each Sht In wb2.Sheets
            Sht.Activate
            ActiveSheet.Copy after:=wb1.Sheets(wb1.Sheets.Count)
        Next Sht
        wb2.Close SaveChanges:=False
    Next i
End If
wb1.Activate
Application.ScreenUpdating = True
Exit Sub
errorhandler:
msgBox Error, vbCritical, "Error"
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
First, no need to do :
Sht.Activate and then
ActiveSheet.Copy after:=wb1.Sheets(wb1.Sheets.Count)

This is heavily slowing the process (avoid Activate and Select as much as possible).



Then you can turn off more (see comments) in the Application to speed up your code :

Dim CalcMode As Long
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    'Turn off events (like Workbook_Open, Worksheet_Change, ...)
    .EnableEvents = False
    'Turn off the Status Bar
    .DisplayStatusBar = False
    'Store initial calculation mode
    CalcMode = .Calculation
    'And set it to manual
    .Calculation = xlCalculationManual
End With 'Application


I've amended a bit your error handler to go back to the part where we reset all those parameters for a regular use.



Opening your workbooks as read-only (as you don't modify them), should improve the speed a bit.



Finally, the use of With/End With allow the code to know which object you are using for multiple rows and will provide a better/faster access to it.



So all of this will speed up your code, but copying sheets is a bit ressources-demanding so it'll probably still be a long, especially if you are opening big files!

Sub SKR_Import()
On Error GoTo ErrorHandler

    Dim CalcMode As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .DisplayStatusBar = False
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
    End With 'Application

    Dim wB1 As Workbook
    Dim wB2 As Workbook
    Dim Sht As Worksheet
    Dim fD As FileDialog
    Dim FileChosen As Integer
    Dim FileName As String
    Dim i As Long

    Set fD = Application.FileDialog(msoFileDialogOpen)
    With fD
        .AllowMultiSelect = True
        .Title = "Select Excel workbooks to import all sheets"
        FileChosen = .Show
    End With

    Set wB1 = ActiveWorkbook
    With wB1
        If FileChosen = -1 Then
            For i = 1 To fD.SelectedItems.Count
                'Open as read-only
                Set wB2 = Workbooks.Open(fD.SelectedItems(i), , True)
                For Each Sht In wB2.Sheets
                    Sht.Copy after:=.Sheets(.Sheets.Count)
                Next Sht
                wB2.Close SaveChanges:=False
            Next i
        End If
    End With 'wB1

ProperExit:
On Error GoTo 0
    wB1.Activate
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
        .DisplayStatusBar = True
        .Calculation = CalcMode
    End With 'Application
Exit Sub
ErrorHandler:
    MsgBox Err.Number &amp; vbCrLf &amp; Err.Description, vbCritical + vbOKOnly, "Error"
    wB2.Close SaveChanges:=False
    Resume ProperExit
End Sub