export data from a access form into an excel sheet

[mugged ur mom]

Hey guys
I’m trying to export data from a access form into an excel sheet when it is clicked by a particular button... but the VB code I’m using for the button will not work.
Here is my current code:

Private Sub Command12_Click()

DoCmd.OutputTo acOutputForm, "frmExport", acFormatXLSX, "h:\mydocu~1\exports\F_assignments.xlsx", True

End Sub

Can somebody please correct my code for me?

I have attached a image of my form as well that may help

[AndreRet]

Have a look at the attachment, It covers all the code to load to excel, save from excel etc. This was a sample done for another member a while back with the same question. If this is what you were looking for, mark this as solved, found at the bottom of this page.:)

[obicerno]

hello guys... this is it... thank you for the help... i own you a lot ... this question of mine was SOLVE.... MORE POWER GUYS.... THANK YOU A LOT...

[AndreRet]

It was a pleasure. Now, please mark this as solved, found at the bottom of this page, thanks.:)

[mugged ur mom]

Have a look at the attachment, It covers all the code to load to excel, save from excel etc. This was a sample done for another member a while back with the same question. If this is what you were looking for, mark this as solved, found at the bottom of this page.:)

I’m sorry I can’t seem to open the attachment for some reason.

Could you please copy and paste the VB code that exports data from an access form into an excel sheet when it is clicked by a particular button in your next post please?

[AndreRet]

This will be the long way around then, just add the controls and change the name instances to what you need in your app.

References - MS Active X Data Objects 2.x
MS Excel x Object Library (x = excel version)

'In your form...
Option Explicit

'I have set the property "MaxLength" of txtSex to 1, this will ensure that only 1 letter is accepted i.e. M,F.
'You do not want mixed data in your database as in M, F, Male, Female etc. See the code on
'txtSex that will only accept M or F as text.
'I have also set your txtID "locked" property to True. You do not want a user to play with this.

'First declare data connection
Private WithEvents cnConn As ADODB.Connection

Private WithEvents rsAddNew As ADODB.Recordset
Private WithEvents rsSearch As ADODB.Recordset
Private WithEvents rsShowData As ADODB.Recordset
Private WithEvents rsDuplicate As ADODB.Recordset
Private WithEvents rsNewIdNumber As ADODB.Recordset
Private WithEvents rsSave As ADODB.Recordset
Private WithEvents rsLoadGrid As ADODB.Recordset
Private WithEvents rsDelete As ADODB.Recordset
Private WithEvents rsExcel As ADODB.Recordset

Dim xl As New Excel.Application
Dim xlsheet As Excel.Worksheet
Dim xlwbook As Excel.Workbook

Private Sub SaveData()

Set rsSave = New ADODB.Recordset

rsSave.Open "SELECT * FROM JEFFTEST", cnConn, adOpenStatic, adLockOptimistic

rsSave.AddNew
        
rsSave!STUDID = txtId.Text
rsSave!FNAME = txtFirst.Text
rsSave!LNAMSE = txtLast.Text
rsSave!SEX = txtSex.Text
rsSave!LDOB = Format(txtDate.Text, "yyyy/mm/dd")
        
rsSave.Update

Call sClear(Me)
Call DoGeneral

tmrLoadGrid.Enabled = True
End Sub

Private Sub GetNewIdNumber()

Set rsNewIdNumber = New ADODB.Recordset

rsNewIdNumber.Open "SELECT * FROM JEFFTEST", cnConn, adOpenStatic, adLockOptimistic

Dim i As Integer

i = rsNewIdNumber.RecordCount + 1

txtId.Text = i
End Sub

Private Sub CheckForDuplicate()

'the benifit of placing numbers in (row, col) is that you
'can loop through different directions if required. I could
'have used column names like “A1? ‘etc.

fraData.Visible = True
fraData.Enabled = False

Set xlwbook = xl.Workbooks.Open(App.Path & "\AS400WorkBook1.xls")
Set xlsheet = xlwbook.Sheets.Item(1)

Dim i As Integer

For i = 1 To 10
        txtId.Text = xlsheet.Cells(i, 1) ' starts at row 1 col 1
        txtFirst.Text = xlsheet.Cells(i, 2) ' row 2 col 2
        txtLast.Text = xlsheet.Cells(i, 3)
        txtSex.Text = xlsheet.Cells(i, 4)
        txtDate.Text = xlsheet.Cells(i, 5)
        
        Set rsExcel = New ADODB.Recordset

        rsExcel.Open "SELECT * FROM JEFFTEST WHERE STUDID = " & "'" & txtId.Text & "'", cnConn, adOpenStatic, adLockOptimistic
        
        If rsExcel.BOF = True Then
        
            If xlsheet.Cells(i, 1) = "" Then
                MsgBox "No new data to add.", vbOKOnly + vbInformation, "No New Data"
                
                Exit Sub
                    Else
                rsExcel.AddNew
                        
                rsExcel!STUDID = txtId.Text
                rsExcel!FNAME = txtFirst.Text
                rsExcel!LNAMSE = txtLast.Text
                rsExcel!SEX = txtSex.Text
                rsExcel!LDOB = Format(txtDate.Text, "yyyy/mm/dd")
            
                rsExcel.Update
                MsgBox "saved"
            End If
        End If
Next

'don’t forget to do this or you’ll not be able to open
'AS400WorkBook1.xls again, untill you restart you pc.
xl.ActiveWorkbook.Close False, App.Path & "\AS400WorkBook1.xls"
xl.Quit

rsExcel.Close

Set rsExcel = Nothing

Call sClear(Me)
Call DoGeneral

tmrLoadGrid.Enabled = True
End Sub

Private Sub DeleteData()

cmdAddNew.Enabled = False
cmdUpload.Enabled = False
cmdDelete.Enabled = True
cmdExit.Enabled = False
cmdSave.Enabled = False
cmdClear.Enabled = True
cmdExitSearch.Enabled = False

Option2.Enabled = False
Option3.Enabled = False
Option5.Enabled = False
End Sub

Private Sub AddData()

Call sClear(Me) 'Clearing all textboxes in current form
'Disable all cmdButtons not needed
cmdAddNew.Enabled = False
cmdUpload.Enabled = False
cmdDelete.Enabled = False
cmdExit.Enabled = False
cmdSave.Enabled = True
cmdClear.Enabled = True
txtFirst.SetFocus 'Let user start adding data from here.
End Sub

Private Sub DoGeneral()

'Disable all cmdButtons not needed etc.
cmdAddNew.Enabled = True
cmdUpload.Enabled = True
cmdDelete.Enabled = True
cmdExit.Enabled = True
cmdSave.Enabled = False
cmdClear.Enabled = True

FraSearch.Visible = False
fraOptions.Visible = True
fraData.Visible = False

Option1.Enabled = True
Option2.Enabled = True
Option3.Enabled = True
Option5.Enabled = True
End Sub

Private Sub ShowData()

Set rsShowData = New ADODB.Recordset

rsShowData.Open "SELECT * FROM JEFFTEST", cnConn, adOpenStatic, adLockOptimistic

txtId.Text = rsShowData!STUDID
txtFirst.Text = rsShowData!FNAME
txtLast.Text = rsShowData!LNAMSE
txtSex.Text = rsShowData!SEX
txtDate.Text = rsShowData!LDOB
End Sub

'This works much better than what you had below.
Private Sub sClear(frm As Form)

Dim Control As Control

 For Each Control In frm.Controls
        If TypeOf Control Is TextBox Then
            Control.Text = ""
        End If
       
    Next Control
End Sub

Private Sub optClear(frm As Form)

Dim Control As Control

 For Each Control In frm.Controls
        If TypeOf Control Is OptionButton Then
            Control.Value = False
        End If
       
    Next Control
End Sub

Private Sub cmdClear_Click()

Call sClear(Me) 'Clear as above all.
Call DoGeneral
End Sub

Private Sub cmdDelete_Click()

If fraData.Visible = False Then
    MsgBox "Please enter the record to be deleted, and click on delete again.", vbOKOnly + vbInformation, "Enter Record"
    
    cmdSearch.Value = True
    Call DeleteData
        Else
    If MsgBox("Are you sure to delete the record for student " & txtLast.Text & "?", vbYesNo + vbQuestion, "Delete Record?") = vbYes Then
        
        Set rsDelete = New ADODB.Recordset

        rsDelete.Open "SELECT * FROM JEFFTEST WHERE STUDID = " & "'" & txtId.Text & "'", cnConn, adOpenStatic, adLockOptimistic
        
        rsDelete.Delete
        
        tmrLoadGrid.Enabled = True
        cmdClear.Value = True
            Else
        cmdClear.Value = True
    End If
End If

Option1.Value = False
End Sub

Private Sub cmdDoSearch_Click()

If txtSearch.Text = "" Then
    MsgBox "No search criteria entered.", vbOKOnly + vbInformation, "No Criteria"
    txtSearch.SetFocus
    
    Exit Sub
        Else
    Dim strCriteria As String
    
    Set rsSearch = New ADODB.Recordset
    
    If Option2.Value = True Or Option3.Value = True Then
        strCriteria = txtCriteria.Text & " = " & "'" & txtSearch.Text & "'"
            Else
        strCriteria = txtCriteria.Text & " = " & "'" & txtSearch.Text & "'"
    End If

rsSearch.Open "SELECT * FROM JEFFTEST WHERE " & strCriteria, cnConn, adOpenStatic, adLockOptimistic

    If rsSearch.BOF = True Or rsSearch.EOF = True Then
        MsgBox "No record found for Student ID " & txtSearch.Text & ".", vbOKOnly + vbInformation, "No Record Found"
        Call sClear(Me)
        Call optClear(Me)
        txtSearch.SetFocus
        
        Exit Sub
            Else
        txtId.Text = rsSearch!STUDID
        txtFirst.Text = rsSearch!FNAME
        txtLast.Text = rsSearch!LNAMSE
        txtSex.Text = rsSearch!SEX
        txtDate.Text = rsSearch!LDOB
        
        fraData.Visible = True
    End If
End If
End Sub

Private Sub cmdExitSearch_Click()

Call sClear(Me)
Call optClear(Me)
Call DoGeneral
End Sub

Private Sub cmdSave_Click()

If txtFirst.Text = "" Then
    MsgBox "No First Name entered.", vbOKOnly + vbInformation, "No Data"
    
    txtFirst.SetFocus
    
    Exit Sub
ElseIf txtLast.Text = "" Then
    MsgBox "No Surname entered.", vbOKOnly + vbInformation, "No Data"
    
    txtLast.SetFocus
    
    Exit Sub
ElseIf txtSex.Text = "" Then
    MsgBox "No Gender entered.", vbOKOnly + vbInformation, "No Data"
    
    txtSex.SetFocus
    
    Exit Sub
ElseIf txtDate.Text = "" Then
    MsgBox "No Date Of Birth entered.", vbOKOnly + vbInformation, "No Data"
    
    txtDate.SetFocus
    
    Exit Sub
        Else
    
    Call SaveData
    Call DoGeneral
    tmrLoadGrid.Enabled = True
    
    MsgBox "New entry saved successfull.", vbOKOnly + vbInformation, "Save Successfull"
End If
End Sub

Private Sub cmdExit_Click()

End
End Sub

Private Sub cmdAddNew_Click()

fraData.Visible = True

txtFirst.SetFocus
tmrGetNewId.Enabled = True
Call AddData
End Sub

Private Sub cmdSearch_Click()

FraSearch.Visible = True
End Sub

Private Sub cmdUpload_Click()

'Call excelapp
Call CheckForDuplicate
End Sub

Private Sub datAs400_DblClick()

mnuId.Caption = ""
mnuName.Caption = ""
mnuSurname.Caption = ""
mnuGender.Caption = ""
mnuDOB.Caption = ""

mnuId.Caption = "Student I.D. Number"
mnuName.Caption = "Student Name"
mnuSurname.Caption = "Student Surname"
mnuGender.Caption = "Student Gender"
mnuDOB.Caption = "Student Date Of Birth"

mnuId.Caption = mnuId.Caption & " - " & datAs400.Columns(0).Text
mnuName.Caption = mnuName.Caption & " - " & datAs400.Columns(1).Text
mnuSurname.Caption = mnuSurname.Caption & " - " & datAs400.Columns(2).Text
mnuGender.Caption = mnuGender.Caption & " - " & datAs400.Columns(3).Text
mnuDOB.Caption = mnuDOB.Caption & " - " & datAs400.Columns(4).Text

PopupMenu mnuGrid
End Sub

Private Sub Form_Load()

Set cnConn = New ADODB.Connection
cnConn.CursorLocation = adUseClient

cnConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\BPCS Files.mdb"

Call sClear(Me)
Call DoGeneral

tmrLoadGrid.Enabled = True
End Sub

Private Sub Form_Unload(Cancel As Integer)

Set xlwbook = Nothing
Set xl = Nothing
End Sub

Private Sub Option1_Click()

fraOptions.Visible = False
txtSearch.Visible = True
Label7.Visible = True
Label7.Caption = "ENTER ID NUMBER TO SEARCH"
txtSearch.SetFocus

txtCriteria.Text = ""
txtCriteria.Text = "STUDID"
End Sub

Private Sub Option2_Click()

fraOptions.Visible = False
txtSearch.Visible = True
Label7.Visible = True
Label7.Caption = "ENTER STUDENT NAME TO SEARCH"
txtSearch.SetFocus

txtCriteria.Text = ""
txtCriteria.Text = "FNAME"
End Sub

Private Sub Option3_Click()

fraOptions.Visible = False
txtSearch.Visible = True
Label7.Visible = True
Label7.Caption = "ENTER STUDENT SURNAME TO SEARCH"
txtSearch.SetFocus

txtCriteria.Text = ""
txtCriteria.Text = "LNAMSE"
End Sub

Private Sub Option5_Click()

fraOptions.Visible = False
txtSearch.Visible = True
Label7.Visible = True
Label7.Caption = "ENTER DATE OF BIRTH TO SEARCH"
txtSearch.SetFocus

txtCriteria.Text = ""
txtCriteria.Text = "LDOB"
End Sub

Private Sub tmrGetNewId_Timer()

Call GetNewIdNumber

tmrGetNewId.Enabled = False
End Sub

Private Sub tmrLoadGrid_Timer()

Set rsLoadGrid = New ADODB.Recordset

rsLoadGrid.Open "SELECT * FROM JEFFTEST", cnConn, adOpenStatic, adLockOptimistic
txtTotalRecords.Text = rsLoadGrid.RecordCount

Set datAs400.DataSource = rsLoadGrid
    
    datAs400.Columns(0).Width = 1650
    datAs400.Columns(1).Width = 2250
    datAs400.Columns(2).Width = 2250
    datAs400.Columns(3).Width = 1450
    datAs400.Columns(4).Width = 1550
        
    datAs400.Columns(0).Caption = "Student I.D."
    datAs400.Columns(1).Caption = "First Name"
    datAs400.Columns(2).Caption = "Surname"
    datAs400.Columns(3).Caption = "Gender"
    datAs400.Columns(4).Caption = "Date Of Birth"
    
    tmrLoadGrid.Enabled = False
End Sub

Private Sub txtDate_Change()
    
If Not IsNumeric(txtDate.Text) Then
        SendKeys "{BackSpace}"
End If
End Sub

Private Sub txtDate_GotFocus()

Call selecttext(txtDate)
End Sub

Private Sub txtDate_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then 'The enter button
    SendKeys "{tab}"
End If
End Sub

Private Sub txtFirst_Change()
    
If IsNumeric(txtFirst.Text) Then
        SendKeys "{BackSpace}"
End If
End Sub

Private Sub txtFirst_GotFocus()

Call selecttext(txtFirst)
End Sub

Private Sub txtFirst_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
    SendKeys "{tab}"
End If
End Sub

Private Sub txtLast_Change()
    
If IsNumeric(txtLast.Text) Then
        SendKeys "{BackSpace}"
End If
End Sub

Private Sub txtLast_GotFocus()

Call selecttext(txtLast)
End Sub

Private Sub txtLast_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
    SendKeys "{tab}"
End If
End Sub

Private Sub txtSex_Change()
    
If IsNumeric(txtSex.Text) Then
        SendKeys "{BackSpace}"
ElseIf Not txtSex.Text = "M" Or txtSex.Text = "F" Then
        SendKeys "{BackSpace}"
End If
End Sub

Private Sub txtSex_GotFocus()

Call selecttext(txtSex)
End Sub

Private Sub txtSex_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
    SendKeys "{tab}"
End If
End Sub


'#####################
'In a module
'#####################

Option Explicit

Public Sub selecttext(txtbox As TextBox)

On Error Resume Next

If txtbox.Text = "" Then
    Exit Sub
        Else
    txtbox.SetFocus
    txtbox.SelStart = 0
    txtbox.SelLength = 65535
End If
End Sub

[mugged ur mom]

ok thank you very much :)

[AndreRet]

No problem, it was a pleasure. Happy coding.:)