Created
November 23, 2016 16:08
-
-
Save Victorcasas/c1c5bf48e252ee08a0388cc56c43ae90 to your computer and use it in GitHub Desktop.
Macro para excel que ejecutada consulta una access para cargar datos, existiendo la Query ya en access
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Option Explicit | |
Sub RunExistingQuery() | |
Dim con As Object | |
Dim rs As Object | |
Dim AccessFile As String | |
Dim strQuery As String | |
Dim i As Integer | |
'Disable screen flickering. | |
Application.ScreenUpdating = False | |
'Specify the file PATH of the accdb file. You can also use the full path of the file like: | |
AccessFile = "C:\Users\Christos\Desktop\Sample.accdb" | |
'Set the name of the QUERY you want to run adn retrieve the data. | |
strQuery = "qrRegions" | |
On Error Resume Next | |
'Create the ADODB connection object. | |
Set con = CreateObject("ADODB.connection") | |
'Check if the object was created. | |
If Err.Number <> 0 Then | |
MsgBox "Connection was not created!", vbCritical, "Connection Error" | |
Exit Sub | |
End If | |
On Error GoTo 0 | |
'Open the connection. | |
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile | |
On Error Resume Next | |
'Create the ADODB recordset object. | |
Set rs = CreateObject("ADODB.Recordset") | |
'Check if the object was created. | |
If Err.Number <> 0 Then | |
'Error! Release the objects and exit. | |
Set rs = Nothing | |
Set con = Nothing | |
'Display an error message to the user. | |
MsgBox "Recordset was not created!", vbCritical, "Recordset Error" | |
Exit Sub | |
End If | |
On Error GoTo 0 | |
'Set thee cursor location. | |
rs.CursorLocation = 3 'adUseClient on early binding | |
rs.CursorType = 1 'adOpenKeyset on early binding | |
'Open the recordset. | |
rs.Open strQuery, con | |
'Check if the recordet is empty. | |
If rs.EOF And rs.BOF Then | |
'Close the recordet and the connection. | |
rs.Close | |
con.Close | |
'Release the objects. | |
Set rs = Nothing | |
Set con = Nothing | |
'Enable the screen. | |
Application.ScreenUpdating = True | |
'In case of an empty recordset display an error. | |
MsgBox "There are no records in the recordset!", vbCritical, "No Records" | |
Exit Sub | |
End If | |
'Copy the recordset headers. | |
For i = 0 To rs.Fields.Count - 1 | |
Sheets("Existing Access Query").Cells(1, i + 1) = rs.Fields(i).Name | |
Next i | |
'Write the QUERY VALUES in the sheet. | |
Sheets("Existing Access Query").Range("A2").CopyFromRecordset rs | |
'Close the recordet and the connection. | |
rs.Close | |
con.Close | |
'Release the objects. | |
Set rs = Nothing | |
Set con = Nothing | |
'Adjust the COLUMNS' width. | |
Columns("A:B").AutoFit | |
'Enable the screen. | |
Application.ScreenUpdating = True | |
'Inform the user that the macro was executed successfully. | |
MsgBox "All data were successfully retrieved from the '" & strQuery & "' query!", vbInformation, "Done" | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment