VBA Databases

Public Sub Example()

    Dim ExcelFilePath As String
    ExcelFilePath = "C:\ExampleData.xlsx"

    Dim CN As Object 'ADODB.Connection
    Set CN = CreateObject("ADODB.Connection")

    CN.ConnectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0" _
        & ";Data Source=" & ExcelFilePath _
        & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    CN.Open

    Dim RS As Object 'ADODB.Recordset
    Set RS = CN.Execute("SELECT * FROM [Sheet1$]")

    Range("A1").CopyFromRecordset RS

    RS.Close
    CN.Close

    Set RS = Nothing
    Set CN = Nothing

End Sub

Public Sub Example()

    Dim ExcelFilePath As String
    ExcelFilePath = "C:\ExampleData.xlsx"

    Dim CN As Object 'ADODB.Connection
    Set CN = CreateObject("ADODB.Connection")

    CN.ConnectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0" _
        & ";Data Source=" & ExcelFilePath _
        & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    CN.Open

    Dim RS As Object 'ADODB.Recordset
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [Sheet1$]", CN, 3 'adOpenStatic

    Debug.Print RS.RecordCount

    RS.MoveFirst
    Do Until RS.EOF
        Debug.Print RS.Fields("Header1").Value
        RS.MoveNext
    Loop

    RS.Close
    CN.Close

    Set RS = Nothing
    Set CN = Nothing

End Sub

Public Sub Example()

    Dim CN As Object 'ADODB.Connection
    Dim CM As Object 'ADODB.Command
    Dim RS As Object 'ADODB.Recordset
    Dim PM As Object 'ADODB.Parameter

    Dim UserInput As Long
    Dim FilePath  As String

    UserInput = Excel.Application.InputBox("Enter Number:", Type:=1)
    FilePath = "C:\ExampleData.xlsx"

    Set CN = CreateObject("ADODB.Connection")
    CN.ConnectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0" _
        & ";Data Source=" & FilePath _
        & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    CN.Open

    Set CM = CreateObject("ADODB.Command")
    Set CM.ActiveConnection = CN
    CM.CommandType = 1 'adCmdText
    CM.CommandText = "SELECT * FROM [Sheet1$] WHERE Header1 = [Param1]"
   'CM.CommandText = "SELECT * FROM [Sheet1$] WHERE Header1 = ?" 'Also works
    CM.Prepared = True
    Set PM = CM.CreateParameter("Param1", 3) 'adInteger
    PM.Value = UserInput
    CM.Parameters.Append PM

    Set RS = CM.Execute

    Range("A1").CopyFromRecordset RS

    RS.Close
    CN.Close

End Sub

Public Sub Example()

    Dim CN As Object 'ADODB.Connection
    Dim CM As Object 'ADODB.Command
    Dim RS As Object 'ADODB.Recordset
    Dim PM As Object 'ADODB.Parameter

    Dim UserInput As Long
    Dim FilePath  As String

    UserInput = Excel.Application.InputBox("Enter Number:", Type:=1)
    FilePath = "C:\ExampleData.xlsx"

    Set CN = CreateObject("ADODB.Connection")
    CN.ConnectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0" _
        & ";Data Source=" & FilePath _
        & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    CN.Open

    Set CM = CreateObject("ADODB.Command")
    Set CM.ActiveConnection = CN
    CM.CommandType = 1 'adCmdText
    CM.CommandText = "SELECT * FROM [Sheet1$] WHERE Header1 = ?"
    CM.Prepared = True

    Set RS = CM.Execute(Parameters:=Array(UserInput))

    Range("A1").CopyFromRecordset RS

    RS.Close
    CN.Close

End Sub

Public Function GetAccessDatabaseTableData(SourceFilePath As String, _
TableName As String) As Variant()

    '''Read all from Access database table into 2D Variant array

    Dim CN    As Object 'ADODB.Connection
    Dim RS    As Object 'ADODB.Recordset
    Dim CS    As String
    Dim i     As Long
    Dim j     As Long
    Dim Arr() As Variant

    On Error GoTo SafeExit

    'Validate Access file exists
    If Dir(SourceFilePath) = "" Then
        Err.Raise 53
    End If

    'Build connection string
    CS = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
         "Dbq=" & SourceFilePath & ";"

    'Open connection to Access database
    Set CN = CreateObject("ADODB.Connection")
    CN.ConnectionString = CS
    CN.Open

    'Execute SQL query
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM " & TableName, CN, 3 'adOpenStatic
    
    'Dimension Array
    ReDim Arr(1 To RS.RecordCount + 1, 1 To RS.Fields.Count) As Variant

    'Get table headers
    For i = 1 To RS.Fields.Count
        Arr(1, i) = RS.Fields(i - 1).Name
    Next i

    'Get data
    RS.MoveFirst
    For i = 1 To RS.RecordCount
        For j = 1 To RS.Fields.Count
            Arr(i + 1, j) = RS.Fields(j - 1).Value
        Next j
        RS.MoveNext
    Next i

    'Return Array
    GetAccessDatabaseTableData = Arr

    On Error GoTo 0

SafeExit:

    'Close connections and cleanup

    If Not RS Is Nothing Then
        If Not RS.State = 0 Then 'if adStateClosed
            RS.Close
        End If
    End If

    If Not CN Is Nothing Then
        If Not CN.State = 0 Then 'if adStateClosed
            CN.Close
        End If
    End If

    Set RS = Nothing
    Set CN = Nothing

    If Err.Number <> 0 Then
        Err.Raise Err.Number
    End If

End Function

Public Function GetAccessDatabaseTableNames(SourceFilePath As String) As Collection

    '''Get collection of all table names from Access database

    Dim CN    As Object 'ADODB.Connection
    Dim RS    As Object 'ADODB.Recordset
    Dim CS    As String
    Dim Arr() As String

    On Error GoTo SafeExit

    'Validate Access file exists
    If Dir(SourceFilePath) = "" Then
        Err.Raise 53
    End If

    Set GetAccessDatabaseTableNames = New Collection
    
    'Build connection string
    CS = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
         "Dbq=" & SourceFilePath & ";"

    'Open connection to Access database
    Set CN = CreateObject("ADODB.Connection")
    CN.ConnectionString = CS
    CN.Open

    'Get table names
    Set RS = CN.OpenSchema(20) 'adSchemaTables
    Do While Not RS.EOF
        GetAccessDatabaseTableNames.Add RS.Fields("table_name").Value
        RS.MoveNext
    Loop

    On Error GoTo 0

SafeExit:

    'Close connections and cleanup

    If Not RS Is Nothing Then
        If Not RS.State = 0 Then 'if adStateClosed
            RS.Close
        End If
    End If

    If Not CN Is Nothing Then
        If Not CN.State = 0 Then 'if adStateClosed
            CN.Close
        End If
    End If

    Set RS = Nothing
    Set CN = Nothing

    If Err.Number <> 0 Then
        Err.Raise Err.Number
    End If

End Function

Public Function GetExcelData(SourceFilePath As String, _
SourceSheetName As String) As Variant()

    '''Reads all data from a spreadsheet into a 2D Variant array using ADO

    Dim CN          As Object 'ADODB.Connection
    Dim RS          As Object 'ADODB.Recordset
    Dim ExcelType   As String
    Dim QueryString As String
    Dim CS          As String
    Dim i           As Long
    Dim j           As Long
    Dim Arr()       As Variant

    On Error GoTo SafeExit

    'Validate Excel file exists
    If Dir(SourceFilePath) = "" Then
        Err.Raise 53
    End If

    'Set Excel type string for connection string
    Select Case Right$(SourceFilePath, Len(SourceFilePath) - InStrRev(SourceFilePath, "."))
        Case "xlsx": ExcelType = "Excel 12.0 Xml"
        Case "xlsb": ExcelType = "Excel 12.0"
        Case "xlsm": ExcelType = "Excel 12.0 Macro"
        Case "xls": ExcelType = "Excel 8.0"
        Case Else: Err.Raise 321 'Invalid file format
    End Select

    'Build connection string
    CS = "Provider=Microsoft.ACE.OLEDB.12.0" _
         & ";Data Source=" & SourceFilePath _
         & ";Extended Properties=""" & ExcelType & ";HDR=YES"";"

    'Open connection to Excel file
    Set CN = CreateObject("ADODB.connection")
    CN.ConnectionString = CS
    CN.Open

    'Execute SQL Query
    QueryString = "SELECT * FROM [" & SourceSheetName & "$]"
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open Source:=QueryString, ActiveConnection:=CN, CursorType:=3 'adOpenStatic

    'Dimension Array
    ReDim Arr(1 To RS.RecordCount + 1, 1 To RS.Fields.Count) As Variant

    'Get headers
    For i = 1 To RS.Fields.Count
        Arr(1, i) = RS.Fields(i - 1).Name
    Next i

    'Get data
    RS.MoveFirst
    For i = 1 To RS.RecordCount
        For j = 1 To RS.Fields.Count
            Arr(i + 1, j) = RS.Fields(j - 1).Value
        Next j
        RS.MoveNext
    Next i

    'Return Array
    GetExcelData = Arr

    On Error GoTo 0

SafeExit:

    'Close connection and cleanup

    If Not RS Is Nothing Then
        If Not RS.State = 0 Then 'if adStateClosed
            RS.Close
        End If
    End If

    If Not CN Is Nothing Then
        If Not CN.State = 0 Then 'if adStateClosed
            CN.Close
        End If
    End If

    Set RS = Nothing
    Set CN = Nothing

    If Err.Number <> 0 Then
        Err.Raise Err.Number
    End If

End Function

Public Function GetExcelSheetNames(SourceFilePath As String) As Collection

    '''Get Collection of all sheet names in a Workbook using ADO

    Dim CN        As Object 'ADODB.Connection
    Dim RS        As Object 'ADODB.Recordset
    Dim ExcelType As String
    Dim CS        As String

    Set GetExcelSheetNames = New Collection

    On Error GoTo SafeExit

    'Validate Excel file exists
    If Dir(SourceFilePath) = "" Then
        Err.Raise 53
    End If

    'Set Excel file type for connection string
    Select Case Right$(SourceFilePath, Len(SourceFilePath) - InStrRev(SourceFilePath, "."))
        Case "xlsx": ExcelType = "Excel 12.0 Xml"
        Case "xlsb": ExcelType = "Excel 12.0"
        Case "xlsm": ExcelType = "Excel 12.0 Macro"
        Case "xls": ExcelType = "Excel 8.0"
        Case Else: Err.Raise 321 'Invalid file format
    End Select

    'Build connection string
    CS = "Provider=Microsoft.ACE.OLEDB.12.0" _
         & ";Data Source=" & SourceFilePath _
         & ";Extended Properties=""" & ExcelType & ";HDR=YES"";"

    'Open connection to Excel file
    Set CN = CreateObject("ADODB.connection")
    CN.ConnectionString = CS
    CN.Open

    'Get sheet names
    Set RS = CN.OpenSchema(20) 'adSchemaTables
    Do While Not RS.EOF
        GetExcelSheetNames.Add RS.Fields("table_name").Value
        RS.MoveNext
    Loop

    On Error GoTo 0

SafeExit:

    'Close connection and cleanup

    If Not RS Is Nothing Then
        If Not RS.State = 0 Then 'if adStateClosed
            RS.Close
        End If
    End If

    If Not CN Is Nothing Then
        If Not CN.State = 0 Then 'if adStateClosed
            CN.Close
        End If
    End If

    Set RS = Nothing
    Set CN = Nothing

    If Err.Number <> 0 Then
        Err.Raise Err.Number
    End If

End Function