Get data from multiple sheets in a selected workbook

Question

I'm new to macros in Excel and I need to make a macro that get data from multiple sheets in a selected workbook.

So far I have this code to select a file and get data from sheet 1, but I want it to be able to get information from all the sheets in the selected file.

Sub MergeSelectedWorkbooks()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim SelectedFiles() As Variant
    Dim NRow As Long
    Dim FileName As String
    Dim NFile As Long
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range

    ' Create a new workbook and set a variable to the first sheet.
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

    ' Modify this folder path to point to the files you want to use.
    FolderPath = "C:\Users\My\Desktop\Path"

    ' Set the current directory to the the folder path.
    ChDrive FolderPath
    ChDir FolderPath

    ' Open the file dialog box and filter on Excel files, allowing multiple files
    ' to be selected.
    SelectedFiles = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)

    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 1

    ' Loop through the list of returned file names
    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        ' Set FileName to be the current workbook file name to open.
        FileName = SelectedFiles(NFile)

        ' Open the current workbook.
        Set WorkBk = Workbooks.Open(FileName)


        ' Set the source range to be A9 through C9.
        ' Modify this range for your workbooks. It can span multiple rows.
        Set SourceRange = WorkBk.Worksheets(1).Range("A1:G5")

        ' Set the destination range to start at column B and be the same size as the source range.
        Set DestRange = SummarySheet.Range("A" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)

        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value

        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count

        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
    Next NFile

    ' Call AutoFit on the destination sheet so that all data is readable.
    SummarySheet.Columns.AutoFit
End Sub

Answer 1

To do this with Excel Automation, first define the following function, which gets the last used cell in a worksheet, using the technique outlined here:

Function LastUsedCell(wks As Excel.Worksheet) As Excel.Range
With wks
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        Set LastUsedCell = .Cells.Find(What:="*", _
            After:=.Range("A1"), _
            Lookat:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False)
    End If
End With
End Function

and this helper function, to determine where to start copying the data from each worksheet:

Function GetNextRowStart(wks As Excel.Worksheet) As Excel.Range
Dim lastCell As Excel.Range
Dim nextRow As Integer
nextRow = 1
Set lastCell = LastUsedCell(wks)
If Not lastCell Is Nothing Then nextRow = lastCell.Row + 1
Set GetNextRowStart = wks.Cells(nextRow, 1)
End Function

Then you can use the following code:

Dim outputWorkbook As Excel.Workbook
Dim outputWorksheet As Excel.Worksheet
Dim filepath As Variant

Set outputWorkbook = Workbooks.Open("D:\Zev\Clients\stackoverflow\outputMultipleWokrbooksWithADO\output.xlsx")
Set outputWorksheet = outputWorkbook.Sheets("Sheet1")

For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    Dim wkbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    Set wkbk = Workbooks.Open(filepath, , True)
    For Each wks In wkbk.Sheets
        Dim sourceRange As Excel.Range
        Dim outputRange As Excel.Range
        With wks
            Set sourceRange = .Range(.Cells(1, 1), LastUsedCell(wks))
        End With
        Set outputRange = GetNextRowStart(outputWorksheet)
        sourceRange.Copy outputRange
    Next
Next

outputWorksheet.Columns.AutoFit

---

The previous approach uses Excel Automation -- open the workbook, get a hold of the sheet, manipulate ranges on the source and output sheets. Data can be copied as is or transformed in some way, during the move.

You can also use ADODB to read the Excel sheets as if the workbook was a database and the worksheets were its tables; and then issue an INSERT INTO statement to copy the original records into the output workbook. It offers the following benefits:

• As a general rule, transferring data via SQL is faster than transferring data via Automation (opening the workbook, copying and pasting the range).
  • If there is no transformation of the data, another option is to read the Value property of a Range object, which returns a two-dimensional array. This can easily be assigned / pasted to anything which expects such an array, including the Value property itself.
• Transforming data with SQL is declarative -- just define the new form of the data. In contrast, transforming the data with Automation implies reading each row and running some code on each row.
  • A more declarative option might be to write an Excel formula into one of the columns, and copy and paste the values.

However, it suffers from the following limitations:

• This works by issuing an SQL statement. If you are not familiar with SQL, this may not be useful to you.
• The data can be transformed only with SQL-supported functions and control statements -- no VBA functions.
• This approach doesn't transfer the formatting.
• INSERT INTO requires that the source and the destination have the same number of fields, with the same data types. (In this case, the SQL can be modified to insert to a different set or order of destination fields, and to use different source fields).
• Excel sometimes gets confused about the column data types.
• Newer versions of Office (2010+) will not allow inserting/updating an Excel file with pure SQL. You'll get the following message: You cannot edit this field because it resides in a linked Excel spreadsheet. The ability to edit data in a linked Excel spreadsheet has been disabled in this Access release.
  • It is still possible to read from the input files, and create an ADO Recordset from them. Excel has a CopyFromRecordset method, that might be useful instead of using INSERT INTO.
  • The old Jet provider is still allowed to do this, but that means only .xls input and output, no .xlsx. (Of course, you could then use Automation to open the .xls file and save it as .xlsx.)
• When reading the worksheet names via OpenSchema, if AutoFilter is turned on, there will be an extra table per worksheet -- for 'Sheet1$', there will be 'Sheet1$'FilterDatabase (or Sheet1$_ when using the Jet provider).

---

Add a reference (Tools -> References ...) to Microsoft ActiveX Data Objects. (Choose the latest version; it's usually 6.1).

The output workbook and worksheet should exist. Also, both the input and output workbooks should be closed while running this code.

Dim filepath As Variant
Dim outputFilePath As String
Dim outputSheetName As String

'To which file and sheet within the file should the output go?
outputFilePath = "c:\path\to\ouput.xls"
outputSheetName = "Sheet1"

For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    Dim conn As New ADODB.Connection
    Dim schema As ADODB.Recordset
    Dim sql As String
    Dim sheetname As Variant
    
    With conn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=""" & filepath & """;" & _
            "Extended Properties=""Excel 12.0;HDR=No"""

        'To use the old Microsoft Jet provider:
        '.Provider = "Microsoft.Jet.OLEDB.4.0"
        '.ConnectionString = "Data Source=""" & filepath & """;" & _
        '    "Extended Properties=""Excel 8.0;HDR=No"""            

        .Open
    End With
    Set schema = conn.OpenSchema(adSchemaTables)
    For Each sheetname In schema.GetRows(, , "TABLE_NAME") 'returns a 2D array of one column
        'This appends the data into an existing worksheet
        sql = _
            "INSERT INTO [" & outputSheetName & "$] " & _
                "IN """ & outputFilePath & """ ""Excel 12.0;"" " & _
            "SELECT * " & _
            "FROM [" & sheetname & "]"
        
        'To create a new worksheet, use SELECT..INTO:
        'sql = _
        '    "SELECT * " & _
        '    "INTO [" & outputSheetName & "$] " & _
        '        "IN """ & outputFilePath & """ ""Excel 12.0;"" " & _
        '    "FROM [" & sheetname & "]"

        conn.Execute sql
    Next
Next

Dim wbk As Workbook
Set wbk = Workbooks.Open(outputFilePath)
wbk.Worksheets(outputSheetName).Coluns.AutoFit

---

An alternate approach is to read the data with ADODB into a recordset and then paste it into the output workbook using the CopyFromRecordset method:

Dim filepath As Variant
Dim outputFilePath As String
Dim outputSheetName As String
Dim sql As String
Dim wbk As Workbook, wks As Worksheet
Dim rng As Excel.Range
Dim sheetname As Variant

'To which file and sheet within the file should the output go?
outputFilePath = "c:\path\to\ouput.xlsx"
outputSheetName = "Sheet1"

For Each filepath In Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    Set schema = conn.OpenSchema(adSchemaTables)
    For Each sheetname In schema.GetRows(, , "TABLE_NAME") 'returns a 2D array of one column
        sql = sql & _
            "UNION ALL SELECT F1 " & _
            "FROM [" & sheetname & "]" & _
                "IN """ & filepath & """ ""Excel 12.0;"""
    Next
Next
sql = Mid(sql, 5) 'Gets rid of the UNION ALL from the first SQL

Dim conn As New ADODB.Connection
Dim rs As ADODB.Recordset
 With conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=""" & filepath & """;" & _
        "Extended Properties=""Excel 12.0;HDR=No"""
    .Open
    Set rs = .Execute(sql)
    Set wbk = Workbooks.Open(outputFilePath, , True)
    Set wks = wbk.Sheets(outputSheetName)
    wks.Cells(2, 1).CopyFromRecordset rs
    wks.Columns.AutoFill
    .Close
End With

Jet SQL:

• INSERT INTO statement
• IN clause

ADO:

• Using ADO to Query an Excel Worksheet
• Connecting to an Excel workbook with ADO
• OpenSchema method
• GetRows method

See also this answer, which is doing something similar.

Answer 2

You could try this: https://msdn.microsoft.com/en-us/library/office/gg549168(v=office.14).aspx I don't know if it helps.