1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
| Public Sub WorkArounds()
On Error GoTo Leave
Dim strSQL, SQL As String
Dim Db As ADODB.Connection
Set Db = New ADODB.Connection
Db.CursorLocation = adUseClient
Db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=<AccessPath>"
'Note: In Office Access 2007, use the following line of code:
'Db.Open "PROVIDER=Microsoft.ACE.OLEDB.12.0;Data Source=<AccessPath>"
SQL = "<MyQuery>"
CopyRecordSetToXL SQL, Db
Db.Close
MsgBox "Access has successfully exported the data to excel file.", vbInformation, "Export Successful."
Exit Sub
Leave:
MsgBox Err.Description, vbCritical, "Error"
Exit Sub
End Sub
Private Sub CopyRecordSetToXL(SQL As String, con As ADODB.Connection)
Dim rs As New ADODB.Recordset
Dim x
Dim i As Integer, y As Integer
Dim xlApp As Excel.Application
Dim xlwbBook As Excel.Workbook, xlwbAddin As Excel.Workbook
Dim xlwsSheet As Excel.Worksheet
Dim rnData As Excel.Range
Dim stFile As String, stAddin As String
Dim rng As Range
stFile = "<ExcelPath>"
'Instantiate a new session with the COM-Object Excel.exe.
Set xlApp = New Excel.Application
Set xlwbBook = xlApp.Workbooks.Open(stFile)
Set xlwsSheet = xlwbBook.Worksheets("<WorkSheets>")
xlwsSheet.Activate
'Getting the first cell to input the data.
xlwsSheet.Cells.SpecialCells(xlCellTypeLastCell).Select
y = xlApp.ActiveCell.Column - 1
xlApp.ActiveCell.Offset(1, -y).Select
x = xlwsSheet.Application.ActiveCell.Cells.Address
'Opening the recordset based on the SQL query and saving the data in the Excel worksheet.
rs.CursorLocation = adUseClient
If rs.State = adStateOpen Then
rs.Close
End If
rs.Open SQL, con
If rs.RecordCount > 0 Then
rs.MoveFirst
x = Replace(x, "$", "")
y = Mid(x, 2)
Set rng = xlwsSheet.Range(x)
xlwsSheet.Range(x).CopyFromRecordset rs
End If
xlwbBook.Close True
xlApp.Quit
Set xlwsSheet = Nothing
Set xlwbBook = Nothing
Set xlApp = Nothing
End Sub |
Partager