• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Merge Sheet1 from Multiple Workbook using single connection

Chihiro

Excel Ninja
I recently did a project and thought I'd share the concept.

Problem:

Needed to merge Sheet1 of multiple workbooks (number of workbooks can vary). All files shared same data structure. It was requested that source workbooks should not be opened.

Normally, I'd use PowerQuery to merge data. However, in this instance environment had mix of Excel 2010, 2013 and 2016. PowerQuery wasn't available to all users of this workbook.

This left MS Query with parameter passed on using VBA or ADO using ACE.OLEDB . Since I'm not too familiar with manipulating MS Query using VBA I went with ACE.OLEDB

But initial code required connection to be opened for each workbook and was bit messy. This got me thinking on how to use single connection to query all workbooks in a folder.

Solution:
By using "IN" clause you can UNION ALL different workbooks using connection to single workbook. It will work for Excel 2007 and up.

In standard module following codes are used.

Function to return array of full file path for each file in folder.
Code:
Function fileList(strPath As String) As Variant
    Dim fd As FileDialog
    Dim MyPath As String, MyFile As String, tempArr() As String
    Dim fNum As Integer: fNum = 0
   
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   
    With fd
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        If .Show <> -1 Then GoTo NextCode
        MyPath = .SelectedItems(1) & "\"
    End With
   
NextCode:
    MyPath = MyPath
    If Not MyPath = "" Then MyFile = Dir(MyPath & "*.xl*")
    If MyFile = "" Then
        ReDim tempArr(1 To 1): tempArr(1) = ""
        fileList = tempArr
        Exit Function
    End If
   
    Do While MyFile <> ""
        fNum = fNum + 1
        ReDim Preserve tempArr(1 To fNum)
        tempArr(fNum) = MyPath & MyFile
        MyFile = Dir()
    Loop
   
    fileList = tempArr
    Set fd = Nothing
End Function
Main procedure.
Code:
Sub MergeWorkbooks()
Dim cn As Object, rst As Object
Dim strQuery As String, fisrtFile As String
Dim i As Integer, iCols As Integer
Dim x
'Change initial folder as needed
x = fileList("C:\")
If Len(x(1)) > 0 Then
    firstFile = x(1)
Else
    MsgBox "No file found or folder not selected!!", vbCritical
    Exit Sub
End If

OptimizeVBA True

Sheet1.Cells(1).CurrentRegion.Clear
Set cn = CreateObject("ADODB.Connection")

' Add IMEX=1; at end of connection string, if you know some column is alphanumeric mixed
' Or if you don't know if data type is consistent in a column
' It is safer to use IMEX=1; in general. Just note that imported data will be in text format
With cn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & firstFile & ";" & _
                          "Extended Properties=""Excel 12.0 Xml;HDR=Yes;"""
    .CursorLocation = 3
    .Open
End With

'Construct query string
For i = 1 To UBound(x)
    If i = 1 Then
        strQuery = "SELECT * FROM [Sheet1$]"
    Else
        strQuery = strQuery & " UNION ALL SELECT * FROM [Sheet1$] IN '" & x(i) & "' 'Excel 12.0 Xml;'"
    End If
Next

strQuery = strQuery & ";"
Set rst = CreateObject("ADODB.Recordset")
rst.Open strQuery, cn, 1, 3

'Read through record set and return headers to row1
For iCols = 0 To rst.Fields.Count - 1
    Sheet1.Cells(1, iCols + 1).Value = rst.Fields(iCols).Name
Next

Sheet1.Range("A2").CopyFromRecordset rst

OptimizeVBA False
rst.Close
cn.Close

End Sub
Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub
It should be pretty self explanatory how to use it (it uses FileDialog to pick a folder). Demo files attached. Modules are in ADODB_Merge_Sample workbook. Rest are test files to merge.
 

Attachments

Chihiro

Excel Ninja
Cool tool. Too bad it's password protected. I'd love to see the underlying concept and codes.

Hmm, my code currently requires you to know sheet name. May be I can use schema to read sheet names and have option to choose which sheet to merge.
 

Chihiro

Excel Ninja
Just a note for myself. Using ADO to extract sheets present in a workbook.

Code:
Sub GetSheetName()
Dim cn As Object, oSch As Object
Dim strQuery As String, fisrtFile As String
Dim i As Integer

Set cn = CreateObject("ADODB.Connection")
firstFile = "C:\Test\Test.xlsx"
' Add IMEX=1; at end of connection string, if you know some column is alphanumeric mixed
' Or if you don't know if data type is consistent in a column
' It is safer to use IMEX=1; in general. Just note that imported data will be in text format
With cn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & firstFile & ";" & _
                          "Extended Properties=""Excel 12.0 Xml;HDR=Yes;"""
    .CursorLocation = 3
    .Open
End With


Set oSch = cn.OpenSchema(20)

i = 2
While Not oSch.EOF
    If Right(oSch("TABLE_NAME"), 1) = "$" Or Right(oSch("TABLE_NAME"), 2) = "$'" Then
        Cells(i, 1) = oSch("TABLE_NAME")
        i = i + 1
    End If
        oSch.movenext
Wend

oSch.Close
cn.Close

End Sub
 

Marc L

Excel Ninja
This ADODB ACE 12 code reading data from xlsx files
well runs on my local Excel 2003 version !
As post #8 attachment was created under this version …

ACE 12 provider works either with xlsx or with older xls workbooks.
 

Marc L

Excel Ninja
Works only for 2000, XP & 2003 versions if updated with Microsoft Office​
Compatibility Pack for Word, Excel, and PowerPoint File Formats …​
 
Top