Write to Excel using ADO

mdExcel.bas

Option Explicit
 
Public Function ReadFromExcel( _
            ByVal sFileName As String, _
            Optional Workbook As String, _
            Optional ByVal CsvHeader As Boolean) As Recordset
    Dim cn              As ADODB.Connection
    Dim rsDest          As Recordset
    Dim sTable          As String
    Dim sCharset        As String
 
    On Error GoTo EH
    '--- open connection
    Set cn = New ADODB.Connection
    On Error GoTo 0
    If LCase$(Right$(sFileName, 5)) = ".xlsb" Then
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFileName & ";Extended Properties=Excel 12.0"
    ElseIf LCase$(Right$(sFileName, 5)) = ".xlsx" Then
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFileName & ";Extended Properties=Excel 12.0 Xml"
    ElseIf LCase$(Right$(sFileName, 4)) = ".csv" Then
        sCharset = pvReadFromExcelPrefix(sFileName, 3)
        If Left$(sCharset, 2) = Chr$(&HFF) & Chr$(&HFE) Then
            sCharset = "CharacterSet=Unicode" & vbCrLf
        ElseIf Left$(sCharset, 3) = Chr$(&HEF) & Chr$(&HBB) & Chr$(&HBF) Then
            sCharset = "CharacterSet=65001" & vbCrLf
        Else
            sCharset = vbNullString
        End If
        Workbook = Mid$(sFileName, InStrRev(sFileName, "\") + 1)
        sFileName = Left$(sFileName, InStrRev(sFileName, "\"))
        With New ADODB.Stream
            .Open
            .WriteText "[" & Workbook & "]" & vbCrLf & _
                            "Format=Delimited(,)" & vbCrLf & _
                            "DecimalSymbol=." & vbCrLf & _
                            "CurrencyDecimalSymbol=." & vbCrLf & _
                            "CurrencyThousandSymbol=" & vbCrLf & _
                            "ColNameHeader=" & IIf(CsvHeader, "true", "false") & vbCrLf & _
                            "MaxScanRows=0" & vbCrLf & _
                            sCharset
            .SaveToFile sFileName & "schema.ini", adSaveCreateOverWrite
        End With
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFileName & ";Extended Properties=Text"
    Else
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFileName & ";Extended Properties=Excel 8.0"
    End If
    On Error GoTo EH
    If cn.State <> adStateOpen Then
        Exit Function
    End If
    '--- figure out table name
    If LenB(Workbook) <> 0 Then
        sTable = Workbook
    Else
        With cn.OpenSchema(adSchemaTables)
            If .EOF Then
                Exit Function
            End If
            Do While LCase$(!TABLE_NAME.Value) = "database"
                .MoveNext
            Loop
            sTable = Replace(!TABLE_NAME.Value, "''", "'")
        End With
    End If
    '--- open table
    Set rsDest = New ADODB.Recordset
    rsDest.CursorLocation = adUseClient
    rsDest.Open sTable, cn, , adLockOptimistic, adCmdTableDirect
    If rsDest.State <> adStateOpen Then
        Exit Function
    End If
    Set rsDest.ActiveConnection = Nothing
    '--- success
    Set ReadFromExcel = rsDest
    Exit Function
EH:
    Debug.Print Err.Description & " in ReadFromExcel"
End Function
 
Private Function pvReadFromExcelPrefix(sFileName As String, ByVal lMaxSize As Long) As String
    Dim lSize           As Long
    Dim nFile           As Integer
    
    On Error GoTo EH
    lSize = FileLen(sFileName)
    If lSize > 0 Then
        nFile = FreeFile()
        Open sFileName For Binary Access Read Shared As nFile
        pvReadFromExcelPrefix = String$(IIf(lSize < lMaxSize, lSize, lMaxSize), 0)
        Get nFile, , pvReadFromExcelPrefix
        Close nFile
    End If
EH:
End Function
 
Public Function WriteToExcel( _
            rsSrc As Recordset, _
            sFileName As String, _
            Optional Workbook As String) As Recordset
    Dim cn              As ADODB.Connection
    Dim sSQL            As String
    Dim oFld            As ADODB.Field
    Dim sTable          As String
    Dim rsDest          As Recordset
    
    On Error GoTo 0
    '--- open connection
    Set cn = New ADODB.Connection
    On Error GoTo 0
    If LCase$(Right$(sFileName, 5)) = ".xlsb" Then
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFileName & ";Extended Properties=Excel 12.0"
    ElseIf LCase$(Right$(sFileName, 5)) = ".xlsx" Then
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFileName & ";Extended Properties=Excel 12.0 Xml"
    Else
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFileName & ";Extended Properties=Excel 8.0"
    End If
    On Error GoTo EH
    If cn.State <> adStateOpen Then
        Exit Function
    End If
    '--- figure out table name
    If LenB(Workbook) <> 0 Then
        sTable = Workbook
    Else
        sTable = "Export"
    End If
    '--- figure out columns datatypes
    For Each oFld In rsSrc.Fields
        If Len(sSQL) > 0 Then
            sSQL = sSQL & vbCrLf & ", "
        End If
        sSQL = sSQL & "[" & oFld.Name & "]" & vbTab & vbTab
        Select Case oFld.Type
        Case adBoolean
            sSQL = sSQL & "LOGICAL"
        Case adDBTimeStamp, adDate, adDBDate, adDBTime
            sSQL = sSQL & "DATETIME"
        Case adBigInt, adInteger, adSmallInt, adTinyInt, _
                adUnsignedBigInt, adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt, _
                adDouble, adSingle, _
                adDecimal, adNumeric, adCurrency
            sSQL = sSQL & "NUMBER"
        Case Else
            sSQL = sSQL & IIf(oFld.DefinedSize > 255 Or oFld.DefinedSize < 0, "MEMO", "TEXT")
        End Select
    Next
    '--- create and open table
    With cn.OpenSchema(adSchemaTables)
        .Find "TABLE_NAME='" & Replace(sTable, "'", "''") & "'"
        If Not .EOF Then
            cn.Execute "DROP TABLE " & sTable
        End If
    End With
    cn.Execute "CREATE TABLE " & sTable & "(" & vbCrLf & sSQL & vbCrLf & ")"
    Set rsDest = New ADODB.Recordset
    rsDest.Open sTable, cn, , adLockOptimistic, adCmdTable
    If rsDest.State <> adStateOpen Then
        Exit Function
    End If
    '--- dump source recordset
    If Not rsSrc.BOF And Not rsSrc.EOF Then
        rsSrc.MoveFirst
    End If
    Do While Not rsSrc.EOF
        rsDest.AddNew
        For Each oFld In rsSrc.Fields
            rsDest.Fields(oFld.Name).Value = oFld.Value
        Next
        rsDest.Update
        rsSrc.MoveNext
    Loop
    '--- success
    Set WriteToExcel = rsDest
    Exit Function
EH:
    Debug.Print Err.Description & " in WriteToExcel"
End Function

this trick works well in VBA ( Excel ) to manipulate the data.