Can someone help me with vba to export to Excel format (Access 2010).
I use below VBA, Export from combobox working fine see(frm_ExportDataExample) but how to export from FORM see (frmToExcel)
Private Sub cbo_ContactName_AfterUpdate()
Me.cmd_Send2XLS.Enabled = Not IsNull(Me.cbo_ContactName)
End Sub
---------------------------------------------------
Private Sub cmd_Send2Xls_Click()
Dim sXlsFile As String
sXlsFile = CurrentProject.Path & "\Customer.xlsx"
Call ExportRecordset2XLS(sXlsFile, "SELECT * FROM tblCustomer WHERE ID=" & Me.cbo_ContactName)
End Sub
----------------------------------------------------
Private Sub Form_Load()
Me.cmd_Send2XLS.Enabled = False
End Sub
----------------------------------------------------
mod_MSExcel :
==========
Function ExportRecordset2XLS(sXlsFile As String, sQuery As String)
Dim oExcel As Object
Dim oExcelWrkBk As Object
Dim oExcelWrSht As Object
Dim bExcelOpened As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim iCols As Integer
Const xlCenter = -4108
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Error_Handler
Set oExcel = CreateObject("excel.application")
bExcelOpened = False
Else
bExcelOpened = True
End If
On Error GoTo Error_Handler
oExcel.ScreenUpdating = False
oExcel.Visible = True
Set oExcelWrkBk = oExcel.Workbooks.Open(sXlsFile)
DoEvents
Set oExcelWrSht = oExcelWrkBk.Sheets(2)
oExcelWrSht.Activate
Set db = CurrentDb
Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then
For iCols = 0 To rs.Fields.Count - 1
oExcelWrSht.Cells(5, iCols + 1).Value = rs.Fields(iCols).Name
Next
With oExcelWrSht.Range(oExcelWrSht.Cells(5, 1), _
oExcelWrSht.Cells(5, rs.Fields.Count))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
oExcelWrSht.Cells.EntireColumn.AutoFit
oExcelWrSht.Columns("Q:Q").ColumnWidth = 101.86
oExcelWrSht.Cells.EntireRow.AutoFit
oExcelWrSht.Range("A6").CopyFromRecordset rs
oExcelWrSht.Range("A1").Select
Else
MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
GoTo Error_Handler_Exit
End If
End With
Error_Handler_Exit:
On Error Resume Next
oExcel.Visible = True
rs.Close
Set rs = Nothing
Set db = Nothing
Set oExcelWrSht = Nothing
Set oExcelWrkBk = Nothing
oExcel.ScreenUpdating = True
Set oExcel = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: ExportRecordset2XLS" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
Thank you in advance for your help
I use below VBA, Export from combobox working fine see(frm_ExportDataExample) but how to export from FORM see (frmToExcel)
Private Sub cbo_ContactName_AfterUpdate()
Me.cmd_Send2XLS.Enabled = Not IsNull(Me.cbo_ContactName)
End Sub
---------------------------------------------------
Private Sub cmd_Send2Xls_Click()
Dim sXlsFile As String
sXlsFile = CurrentProject.Path & "\Customer.xlsx"
Call ExportRecordset2XLS(sXlsFile, "SELECT * FROM tblCustomer WHERE ID=" & Me.cbo_ContactName)
End Sub
----------------------------------------------------
Private Sub Form_Load()
Me.cmd_Send2XLS.Enabled = False
End Sub
----------------------------------------------------
mod_MSExcel :
==========
Function ExportRecordset2XLS(sXlsFile As String, sQuery As String)
Dim oExcel As Object
Dim oExcelWrkBk As Object
Dim oExcelWrSht As Object
Dim bExcelOpened As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim iCols As Integer
Const xlCenter = -4108
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Error_Handler
Set oExcel = CreateObject("excel.application")
bExcelOpened = False
Else
bExcelOpened = True
End If
On Error GoTo Error_Handler
oExcel.ScreenUpdating = False
oExcel.Visible = True
Set oExcelWrkBk = oExcel.Workbooks.Open(sXlsFile)
DoEvents
Set oExcelWrSht = oExcelWrkBk.Sheets(2)
oExcelWrSht.Activate
Set db = CurrentDb
Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then
For iCols = 0 To rs.Fields.Count - 1
oExcelWrSht.Cells(5, iCols + 1).Value = rs.Fields(iCols).Name
Next
With oExcelWrSht.Range(oExcelWrSht.Cells(5, 1), _
oExcelWrSht.Cells(5, rs.Fields.Count))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
oExcelWrSht.Cells.EntireColumn.AutoFit
oExcelWrSht.Columns("Q:Q").ColumnWidth = 101.86
oExcelWrSht.Cells.EntireRow.AutoFit
oExcelWrSht.Range("A6").CopyFromRecordset rs
oExcelWrSht.Range("A1").Select
Else
MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
GoTo Error_Handler_Exit
End If
End With
Error_Handler_Exit:
On Error Resume Next
oExcel.Visible = True
rs.Close
Set rs = Nothing
Set db = Nothing
Set oExcelWrSht = Nothing
Set oExcelWrkBk = Nothing
oExcel.ScreenUpdating = True
Set oExcel = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: ExportRecordset2XLS" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
Thank you in advance for your help
