Acceder a Access desde Excel mediante VBA

En un reciente curso de Microsoft Access 2010, los alumnos –conocedores de mi preferencia por la programación- me pidieron que hiciera un giro en el temario del curso y lo orientara hacia sus necesidades fundamentales: enlazar bases de datos Access con libros Excel. Así, surgió la necesidad de desarrollar un conjunto procedimientos (la gran mayoría de ellos del tipo FUNCTION).

Para compartir esta información, pongo ese código a la disposición de quién lo necesite.

‘ =================================================================

‘ Para trabajar con ADO, se requiere añadir la referencia:

‘      Microsoft ActiveX Data Objects x.y Library

‘ Para trabajar con ADOX,se requiere añadir la referencia a:

‘      Microsoft ADO Ext. x.y for DDL and Security

‘ Para trabajar con Access.Application,se requiere añadir la referencia a:

‘      Microsoft Access x.y Object Library

‘ Para trabajar con DAO, se requiere añadir la referencia a:

‘      Microsoft DAO x.y Object Library

‘ ====================================================================

Function ReadAccessTableToExcel(ByVal pAccessDatabaseFullName As String, _

                                                    ByVal pAccessTableName As String, _

                                                    ByVal pExcelWorkbookFullName As String, _

                                                    ByVal pExcelTargetSheetName As String) As Boolean

    Dim oConnection  As ADODB.Connection

    Dim oRecordset   As ADODB.Recordset

    Dim oWorkbook  As Workbook

    Dim oWorksheet As Worksheet

    Dim i  As Integer

     On Error GoTo TError

     Set oConnection = New ADODB.Connection

     oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _ 

                                        «Data Source=» & pAccessDatabaseFullName

    Set oRecordset = New ADODB.Recordset

    oRecordset.Open pAccessTableName, oConnection, _ 

                                    adOpenKeyset, adLockOptimistic, adCmdTable

    If FileExist(pExcelWorkbookFullName) = False Then

       Set oWorkbook = Application.Workbooks.Add

    Else

       Set oWorkbook = Application.Workbooks.Open(pExcelWorkbookFullName)

    End If

    If SheetExist(oWorkbook, pExcelTargetSheetName) = False Then

       Set oWorksheet = oWorkbook.Worksheets.Add

       oWorksheet.Name = pExcelTargetSheetName

    Else

       Set oWorksheet = oWorkbook.Worksheets(pExcelTargetSheetName)

    End If

    oWorksheet.UsedRange.Clear

    For i = 0 To oRecordset.Fields.Count – 1

        oWorksheet.Range(«A1»).Offset(, i).Value = oRecordset.Fields(i).Name

    Next i

 

    oWorksheet.Range(«A1»).Resize(, oRecordset.Fields.Count).Font.Bold = True

     oWorksheet.Range(«A2»).CopyFromRecordset oRecordset


Application.DisplayAlerts = False

     oWorkbook.SaveAs (pExcelWorkbookFullName)

     oWorkbook.Close

     Application.DisplayAlerts = True

   
oRecordset.Close

    Set oRecordset = Nothing

     oConnection.Close

    Set oConnection = Nothing

    ReadAccessTableToExcel = True

    Exit Function

TError:

    If Not (oRecordset Is Nothing) Then

       If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close

       Set oRecordset = Nothing

    End If

    If oConnection.State = adStateOpen Then oConnection.Close

    ReadAccessTableToExcel = False

End Function

 

‘ ====================================================================

‘ ====================================================================

Function ReadAccessSQLToExcel(ByVal pAccessDatabaseFullName As String, _

                                                    ByVal pSQLSentence As String, _

                                                   ByVal pExcelWorkbookFullName As String, _

                                                   ByVal pExcelTargetSheetName As String) As Boolean

     Dim oConnection As ADODB.Connection

    Dim oRecordset  As ADODB.Recordset

    Dim sConnection As String

    Dim oWorkbook   As Workbook

    Dim oWorksheet  As Worksheet

    Dim i  As Long

   

    On Error GoTo TError

    Set oConnection = CreateObject(«ADODB.Connection»)

    sConnection = «Provider=Microsoft.ACE.OLEDB.12.0;» & _

                               «Data Source=» & pAccessDatabaseFullName

    oConnection.Open sConnection

    Set oRecordset = oConnection.Execute(pSQLSentence)

    If FileExist(pExcelWorkbookFullName) = False Then

       Set oWorkbook = Application.Workbooks.Add

    Else

       Set oWorkbook = Application.Workbooks.Open(pExcelWorkbookFullName)

    End If

    If SheetExist(oWorkbook, pExcelTargetSheetName) = False Then

       Set oWorksheet = oWorkbook.Worksheets.Add

       oWorksheet.Name = pExcelTargetSheetName

    Else

       Set oWorksheet = oWorkbook.Worksheets(pExcelTargetSheetName)

    End If

    Set oWorksheet = oWorkbook.Worksheets(pExcelTargetSheetName)

    oWorksheet.UsedRange.Clear

    For i = 0 To oRecordset.Fields.Count – 1

        oWorksheet.Range(«A1»).Offset(, i).Value = oRecordset.Fields(i).Name

    Next i


oWorksheet.Range(«A1»).Resize(,
oRecordset.Fields.Count).Font.Bold = True

    oWorksheet.Range(«A2»).CopyFromRecordset oRecordset

    Application.DisplayAlerts = False

    oWorkbook.SaveAs (pExcelWorkbookFullName)

    oWorkbook.Close

    Application.DisplayAlerts = True

    oRecordset.Close

    Set oRecordset = Nothing

    oConnection.Close

    Set oConnection = Nothing

    ReadAccessSQLToExcel = True

    Exit Function

TError:

    If Not (oRecordset Is Nothing) Then

       If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close

         Set oRecordset = Nothing

    End If

    If oConnection.State = adStateOpen Then oConnection.Close

    ReadAccessSQLToExcel = False

 End Function

 

Function GetAccessTableNames(ByVal pAccessDatabaseFullName As String) _

                                                         As String()

     Dim oConnection       As ADODB.Connection

    Dim oCatalog          As ADOX.Catalog

    Dim oTable            As ADOX.Table

    Dim sConnectionString As String

    Dim arrTableNames()   As String

    Dim i                 As Long

    On Error GoTo TError

    sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _

                                         «Data Source=» & pAccessDatabaseFullName

   Set oConnection = New ADODB.Connection

    oConnection.Open sConnectionString

    Set oCatalog = New ADOX.Catalog

    Set oCatalog.ActiveConnection = oConnection

    i = -1

    For Each oTable In oCatalog.Tables

       If oTable.Type = «TABLE» Then

          i = i + 1

          ReDim Preserve arrTableNames(i)

           arrTableNames(i) = oTable.Name

       End If

    Next oTable

    oConnection.Close

    Set oCatalog = Nothing

    Set oConnection = Nothing

    GetAccessTableNames = arrTableNames

    Exit Function

TError:

    If oConnection.State = adStateOpen Then oConnection.Close

End Function

Function GetAccessTableFieldNames(ByVal pAccessDatabaseFullName As String, _

                                                      ByVal pAccessTableName As String) As String()

    Dim oConnection     As ADODB.Connection

    Dim oRecordset      As ADODB.Recordset

    Dim arrFieldNames() As String

    Dim i               As Long

    On Error GoTo TError

     Set oConnection = New ADODB.Connection

     oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _ 

                                       «Data Source=» & pAccessDatabaseFullName

    Set oRecordset = New ADODB.Recordset

    oRecordset.Open pAccessTableName, oConnection, _

                                   adOpenKeyset, adLockOptimistic, adCmdTable

    For i = 0 To oRecordset.Fields.Count – 1

        ReDim Preserve arrFieldNames(i)

        arrFieldNames(i) = oRecordset.Fields(i).Name

    Next i

    oRecordset.Close

    Set oRecordset = Nothing

    oConnection.Close

    Set oConnection = Nothing

    GetAccessTableFieldNames = arrFieldNames

    Exit Function

TError:

    If Not (oRecordset Is Nothing) Then

       If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close

       Set oRecordset = Nothing

    End If

    If oConnection.State = adStateOpen Then oConnection.Close

End Function

Function GetAccessTableFieldTypes(ByVal pAccessDatabaseFullName As String, _

                                                        ByVal pAccessTableName As String) As String()

    Dim oConnection      As ADODB.Connection

    Dim oRecordset       As ADODB.Recordset

    Dim arrFieldTypes()  As String

    Dim i                As Long

     On Error GoTo TError

     Set oConnection = New ADODB.Connection

     oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _

                                       «Data Source=» & pAccessDatabaseFullName

    Set oRecordset = New ADODB.Recordset

    oRecordset.Open pAccessTableName, oConnection, _

    adOpenKeyset, adLockOptimistic, adCmdTable

    For i = 0 To oRecordset.Fields.Count – 1

        ReDim Preserve arrFieldTypes(i)

        arrFieldTypes(i) = TypeName(oRecordset.Fields(i).Value)

    Next i

    oRecordset.Close

    Set oRecordset = Nothing

    oConnection.Close

    Set oConnection = Nothing

    GetAccessTableFieldTypes = arrFieldTypes

    Exit Function

TError:

    If Not (oRecordset Is Nothing) Then

       If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close

       Set oRecordset = Nothing

    End If

    If oConnection.State = adStateOpen Then oConnection.Close

 End Function

 

Function GetAccessTableFieldValues(ByVal pAccessDatabaseFullName As String, _

                                                                   ByVal pAccessTableName As String, _

                                                                  ByVal pFieldName As String) As Variant()

    Dim oConnection      As ADODB.Connection

    Dim oRecordset       As ADODB.Recordset

    Dim arrFieldValues() As Variant

    Dim i                As Long

    On Error GoTo TError

    Set oConnection = New ADODB.Connection

    oConnection.Open «Provider=Microsoft.Ace.OLEDB.12.0; » & _

                                       «Data Source=» & pAccessDatabaseFullName

    Set oRecordset = New ADODB.Recordset

    oRecordset.Open pAccessTableName, oConnection, _

                                   adOpenKeyset, adLockOptimistic, adCmdTable

    ReDim arrFieldValues(oRecordset.RecordCount – 1)

    i = -1

    Do While Not oRecordset.EOF

       i = i + 1

       arrFieldValues(i) = oRecordset.Fields(pFieldName).Value

       oRecordset.MoveNext

    Loop

    oRecordset.Close

    Set oRecordset = Nothing

    oConnection.Close

    Set oConnection = Nothing

    GetAccessTableFieldValues = arrFieldValues

    Exit Function

TError:

    If Not (oRecordset Is Nothing) Then

       If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close

       Set oRecordset = Nothing

    End If

    If oConnection.State = adStateOpen Then oConnection.Close

End Function

 

Function GetAccessQueryNames_1(ByVal pAccessDatabaseFullName As String) _

                                                                As String()

    Dim sConnectionString As String

    Dim oConnection       As ADODB.Connection

    Dim oCatalog          As ADOX.Catalog

    Dim oView             As ADOX.View

    Dim arrQueryNames()   As String

    Dim i                 As Long

    On Error GoTo TError

     sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _

                                          «Data Source=» & pAccessDatabaseFullName

    Set oConnection = New ADODB.Connection

     oConnection.Open sConnectionString

    Set oCatalog = New ADOX.Catalog

    Set oCatalog.ActiveConnection = oConnection

     i = -1

    For Each oView In oCatalog.Views

       i = i + 1

       ReDim Preserve arrQueryNames(i)

       arrQueryNames(i) = oView.Name

    Next oView  

    oConnection.Close

    Set oCatalog = Nothing

    Set oConnection = Nothing

    GetAccessQueryNames_1 = arrQueryNames

    Exit Function

TError:

    If oConnection.State = adStateOpen Then oConnection.Close

End Function

 

Function GetAccessQueryNames_2(ByVal pAccessDatabaseFullName As String) _

                                                                As  String()

    Dim  oDatabase       As DAO.Database

    Dim oQueryDef       As DAO.QueryDef

    Dim arrQueryNames() As String

    Dim i               As Long

    On Error GoTo TError

    Set oDatabase = DBEngine.OpenDatabase(pAccessDatabaseFullName)

    i = -1

    For Each oQueryDef In oDatabase.QueryDefs

       If Mid(oQueryDef.Name, 1, 1) <> «~» Then

          i = i + 1

          ReDim Preserve arrQueryNames(i)

          arrQueryNames(i) = oQueryDef.Name

       End If

    Next


oQueryDef.Close

    Set oQueryDef = Nothing

    oDatabase.Close

    Set oDatabase = Nothing

    GetAccessQueryNames_2 = arrQueryNames

    Exit Function

  TError:

    On Error Resume Next

    oQueryDef.Close

    On Error Resume Next

    oDatabase.Close

End Function

 

Function GetAccessQuerySELECTFromQueryName(ByVal pAccessDatabaseFullName As String, _

                                   ByVal pAccessQueryName As String) As String

    Dim oDatabase As DAO.Database

    Dim oQueryDef As DAO.QueryDef

    On Error GoTo TError

    Set oDatabase = DBEngine.OpenDatabase(pAccessDatabaseFullName)

    Set oQueryDef = oDatabase.QueryDefs(pAccessQueryName)

    GetAccessQuerySELECTFromQueryName = oQueryDef.Sql

    oDatabase.Close

    Set oDatabase = Nothing

    Exit Function

TError:

    On Error Resume Next

    oDatabase.Close

    GetAccessQuerySELECTFromQueryName = «»

End Function

 

Function ExecuteAccessQueryName(ByVal pAccessDatabaseFullName As String, _

                                          ByVal pAccessQueryName As String) As ADODB.Recordset

    Dim sConnectionString As String

    Dim oConnection       As ADODB.Connection

    Dim oRecordset        As ADODB.Recordset

    Dim sSQL              As String

    On Error GoTo TError

    sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _

                                         «Data Source=» & pAccessDatabaseFullName

    Set oConnection = New ADODB.Connection

    oConnection.Open sConnectionString

    sSQL = GetAccessQuerySELECTFromQueryName(pAccessDatabaseFullName, _
pAccessQueryName)

    Set oRecordset = oConnection.Execute(sSQL)                          

    Set ExecuteAccessQueryName = oRecordset

    Set oRecordset = Nothing

    Exit Function

TError:

    On Error Resume Next

    Set oRecordset = Nothing

    Set ExecuteAccessQueryName = Nothing

End Function

 

Function ExecuteAccessQuerySELECT(ByVal pAccessDatabaseFullName As String, _

                                       ByVal pAccessQuerySELECT As String) As ADODB.Recordset

    Dim sConnectionString As String

    Dim oConnection       As New ADODB.Connection

    Dim oRecordset        As New ADODB.Recordset

    Dim oCommand          As New ADODB.Command

    On Error GoTo TError

    sConnectionString = «Provider=Microsoft.ACE.OLEDB.12.0;» & _

                                         «Data Source=» & pAccessDatabaseFullName

    oConnection.Open sConnectionString

    oCommand.CommandType = adCmdText

    oCommand.CommandText = pAccessQuerySELECT

    oCommand.ActiveConnection = oConnection

    Set oRecordset = oCommand.Execute()

    Set ExecuteAccessQuerySELECT = oRecordset

    Set oCommand = Nothing

    Set oRecordset = Nothing

    oConnection.Close

    Set oConnection = Nothing

    Exit Function

TError:

    If Not (oRecordset Is Nothing) Then

       If (oRecordset.State And adStateOpen) = adStateOpen Then oRecordset.Close

       Set oRecordset = Nothing

    End If

    If oConnection.State = adStateOpen Then oConnection.Close

    Set ExecuteAccessQuerySELECT = Nothing

End Function