Access vba code to Export tbl data to Excel spreadsheet 1

[ckeola]

I have tried and tried... and am not vba savvy...
I have a form in an Access db that has a button that I need to be able press and it exports tbl data to Excel.

Access Database I am working from: "my_db"
Table I need to export(w/out headers): "my_tbl"
Excel workbook(already exists) I need to export to: "C:\folder\my_excel"
Spreadsheet in "my_excel" to export to: "my_spreadsheet"

I have been told to Paste Special - CSV into the Excel spreadsheet.

So I would need this export to do the same into the first empty Cell in Column A.

Can anyone please help me with this, it would make my life so much easier.... thank you for even reading this, and once more for answering.

 

[PHV]

Have a look at the DoCmd.TransferSpreadsheet method.

Another way is to use MS-Query in the Excel workbook.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[ckeola]

every time I try to code something it doesn't work. I need code...
simply because I have 20,000 rows of data that I have to check through and any time I can shave off (like copying and pasting/CSV)

 

[SkipVought]

every time I try to code something it doesn't work.

Please post an example of the code that you tried and did not work, AND explain EXACTLY what you mean by 'doesn't work' as that COULD mean any number if different things.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[ckeola]

I have been trying different stuff and at my ropes end with this one.... this was my latest attempt.

Private Sub Command61_Click()
DoCmd.TransferSpreadsheet acExport, "Microsoft Excel", "C:\folder\my_Excel", _
acTable, "my_tbl", _
End Sub

The errors I get range from type mismatch to... lets just say a bunch.

All I want to do:
push button on my form and the following happens...
- all the data in "my_tbl" is selected and copied
- paste copied data(something comparable to paste special/CSV) into the first empty cell of Column A in the existing workbook: "my_excel", on the existing spreadsheet: "my_spreadsheet".

Also, "my_excel" will already be open, but minimized

 

[bubba100]

Given your desires I don't believe the TransferSpeadsheet method is what you want. Sense you already have your destination file open might take a look in Excel at the CopyFromRecordSet method.
A recordset can be about anything. Your table is a recordset, the results of a query is a recordset.

 

[ckeola]

The problem with that is:
I am not allowed to change any formatting/coding in the Excel doc because I am not the only one that uses it.

I can only insert new data.

 

[PHV]

I can only insert new data
So, insert new data with the CopyFromRecordset method of the Excel.Range object.

 

[GComyn]

There is a way... I remember seeing it somewhere.. but I can't remember, and there is alot of code and API calls...

I'll see if I can either find it or figure it out.

GComyn

 

[GComyn]

Ok.. I haven't the way that I thought... for the following code, you will need to close the spreadsheet. The code will open it itself, then find the bottom of the current list, and then go through the table as a recordset (dao) and put the fields in the cells on the excel spreadsheet.

you just change the name of the fields within the loop to correspond with the fields in my_tbl, and put them in the correct cells.

Public Sub Testing_Save_To_Open_Excel()
    Dim strTable As String
    Dim strFile As String
    Dim objApp As Excel.Application
    Dim objExl As Excel.Workbook
    Dim objSheet As Excel.worksheet
    Dim rs As DAO.Recordset
    Dim lngCount As Long
    
    Set rs = CurrentDb.OpenRecordset("my_tbl")
    Set objExl = Workbooks.Open("C:\folder\my_excel.xlsx")
    Set objApp = objExl.Parent
    
    Set objSheet = objExl.Worksheets("my_spreadsheet")
    objSheet.Activate
    Range("a1").Activate
    objApp.Visible = True
    
    objSheet.Range("a65536").End(xlUp).Offset(1, 0).Activate
    lngCount = CInt(Mid(ActiveCell.Address, 4))
    If rs.RecordCount > 0 Then
        rs.MoveFirst
        Do While Not rs.EOF
            With rs
                objSheet.Range("a" & lngCount).Value = !Report_Name
                objSheet.Range("b" & lngCount).Value = !REPORT_DT
                objSheet.Range("c" & lngCount).Value = !BANKOWN
                objSheet.Range("d" & lngCount).Value = !CLTRNAME
                objSheet.Range("e" & lngCount).Value = !CLTR
                objSheet.Range("f" & lngCount).Value = !ACCOUNT
                objSheet.Range("g" & lngCount).Value = !DTRNAME
                objSheet.Range("h" & lngCount).Value = !UPLOAD_BAL
                objSheet.Range("i" & lngCount).Value = !RCV1_BAL
                objSheet.Range("j" & lngCount).Value = !BAL_DIFF
                objSheet.Range("k" & lngCount).Value = !OTHER_AGCY
                objSheet.Range("l" & lngCount).Value = !DT_ASSIGN
                objSheet.Range("m" & lngCount).Value = !Prin
                objSheet.Range("n" & lngCount).Value = Nz(!Int, "")
                objSheet.Range("o" & lngCount).Value = !Other
                objSheet.Range("p" & lngCount).Value = !Costs
                objSheet.Range("q" & lngCount).Value = !RC_SYS
                objSheet.Range("r" & lngCount).Value = !TYPCD
                objSheet.Range("s" & lngCount).Value = !System
                objSheet.Range("t" & lngCount).Value = !PreviousTimes
                objSheet.Range("u" & lngCount).Value = !Title_Order
                objSheet.Range("v" & lngCount).Value = !Total_Title
                objSheet.Range("w" & lngCount).Value = !TotalNumber
                objSheet.Range("x" & lngCount).Value = !Duplicated
            End With
            lngCount = lngCount + 1
            rs.MoveNext
        Loop
    End If
    
    rs.Close: Set rs = Nothing
    Set objSheet = Nothing
    Set objExl = Nothing
    Set objApp = Nothing
End Sub

I'll continue to look to see if I can find a way to take over an existing (open) spreadsheet.

GComyn

 

[bubba100]

I'll be in the office tomorrow and will have something to show you.

hint-- use GetObject to reference the open instance of Excel. Hopefully you only have ONE workbook open...

 

[bubba100]

Given your desires this is another way. You will need to change to YOUR table name, workbook name and worksheet name.

It has several shortcomings that COULD effect you, like it looks to see if Excel is open if so it goes to Sheet3 and drops the data starting in cell A2. What if the file open isn't the one you really wanted?

IF you want to add data to what is already there, then you need to adjust the code to move the end.

Private Sub Command33_Click()
On Error GoTo Err_Command33_Click
Dim oExcel As Excel.Application
Dim db As Database
Dim RS As Recordset
Dim bRunning As Boolean
Dim iAnswer As Integer
Dim iColumn As Integer
Dim sData As String
Dim fldLoop As Field
Dim fldCount As Integer
On Error GoTo Err_Command33_Click
Screen.MousePointer = 11
Set db = CurrentDb
Set RS = db.OpenRecordset("tblFuel")
If RS.EOF Then
Screen.MousePointer = 0
Set db = Nothing
Beep
MsgBox "This resulted in 0 records found.", vbInformation, "No Records Found"
Exit Sub
End If
RS.MoveLast
RS.MoveFirst
iAnswer = 6
If RS.RecordCount > 1000 Then
Screen.MousePointer = 0
iAnswer = MsgBox("This resulted in " & RS.RecordCount & " records. Continue to Excel?", vbQuestion + vbYesNo, "High Record Count")
End If
If iAnswer = 6 Then
bRunning = True
Screen.MousePointer = 11
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
On Error GoTo Err_Command33_Click
If oExcel Is Nothing Then
Set oExcel = CreateObject("Excel.application")
bRunning = False
oExcel.Workbooks.Open "C:\My Documents\My_Excel_File.xls"
End If
oExcel.Worksheets("Sheet3").Activate
DoEvents
oExcel.Range("a2").CopyFromRecordset RS
iColumn = 1
For Each fldLoop In RS.Fields
sData = fldLoop.Name
oExcel.Cells(1, iColumn) = sData
iColumn = iColumn + 1
Next
End If



Exit_Command33_Click:
Screen.MousePointer = 0
RS.Close
Set RS = Nothing
Set db = Nothing
Set oExcel = Nothing
Exit Sub

Err_Command33_Click:
MsgBox Err.Description
Screen.MousePointer = 0
Set RS = Nothing
Set db = Nothing
Set oExcel = Nothing
Resume Exit_Command33_Click

End Sub

 

[GComyn]

Great code bubba100! after testing it, and looking up getobject in the help system, here is my adaptation of your code, from what I understand ckeola was asking for.

Option Compare Database
Option Explicit

Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
                    ByVal lpWindowName As Long) As Long

Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
                    ByVal wParam As Long, _
                    ByVal lParam As Long) As Long


Private Sub Command33_Click()
On Error GoTo Err_Command33_Click
    Dim oExcel As Excel.Application
    Dim oSht As Excel.Worksheet
    Dim db As Database
    Dim RS As DAO.Recordset
    Dim bRunning As Boolean
    Dim iAnswer As Integer
    Dim iColumn As Integer
    Dim sData As String
    Dim fldLoop As Object
    Dim fldCount As Integer
    Dim ExcelWasNotRunning As Boolean    ' Flag for final release
    Dim strActiveCell As String
    
    Screen.MousePointer = 11
    Set db = CurrentDb
    Set RS = db.OpenRecordset("my_tbl")
    If RS.EOF Then
        Screen.MousePointer = 0
        Set db = Nothing
        Beep
        MsgBox "This resulted in 0 records found.", vbInformation, "No Records Found"
        Exit Sub
    End If
    RS.MoveLast
    RS.MoveFirst
    iAnswer = 6
    If RS.RecordCount > 1000 Then
        Screen.MousePointer = 0
        iAnswer = MsgBox("This resulted in " & RS.RecordCount & " records.  Continue to Excel?", vbQuestion + vbYesNo, "High Record Count")
    End If
    If iAnswer = 6 Then
        bRunning = True
        Screen.MousePointer = 11
        On Error Resume Next
'     Getobject function called without the first argument returns a
'     reference to an instance of the application. If the application isn't
'     running, an error occurs.
        Set oExcel = GetObject(, "Excel.Application")
        If Err.Number <> 0 Then ExcelWasNotRunning = True
        Err.Clear    ' Clear Err object in case error occurred.

'     Check for Microsoft Excel. If Microsoft Excel is running,
'     enter it into the Running Object table.
        DetectExcel
    
'     Set the object variable to reference the file you want to see.
        Set oExcel = GetObject("c:\folder\my_excel.xlsx")
'     Show Microsoft Excel through its Application property. Then
'     show the actual window containing the file using the Windows
'     collection of the MyXL object reference.
        oExcel.Application.Visible = True
        oExcel.Parent.Windows(1).Visible = True
        Set oSht = oExcel.Worksheets("my_spreadsheet")
        
        On Error GoTo Err_Command33_Click
        oSht.Activate
        DoEvents
        
        strActiveCell = oSht.Range("a65536").End(xlUp).Offset(1, 0).Address
        oSht.Range(strActiveCell).CopyFromRecordset RS
        
'        Remove this next for loop if you do not want the first row to have the field names
'        iColumn = 1
'        For Each fldLoop In RS.Fields
'            sData = fldLoop.Name
'            oExcel.Cells(1, iColumn) = sData
'            iColumn = iColumn + 1
'        Next
    End If
    
Exit_Command33_Click:
' If this copy of Microsoft Excel was not running when you
' started, close it using the Application property's Quit method.
' Note that when you try to quit Microsoft Excel, the
' title bar blinks and a message is displayed asking if you
' want to save any loaded files.
    If ExcelWasNotRunning = True Then
        oExcel.Application.Quit
    End If

    Set oExcel = Nothing    ' Release reference to the application and spreadsheet.
    
    Screen.MousePointer = 0
    Set RS = Nothing
    Set db = Nothing
    Set oSht = Nothing
    Set oExcel = Nothing
    Exit Sub
    
Err_Command33_Click:
    MsgBox Err.Description
    Screen.MousePointer = 0
    Set RS = Nothing
    Set db = Nothing
    Set oSht = Nothing
    Set oExcel = Nothing
    Resume Exit_Command33_Click
End Sub

Sub DetectExcel()
' Procedure dectects a running Excel and registers it.
    Const WM_USER = 1024
    Dim hWnd As Long
' If Excel is running this API call returns its handle.
    hWnd = FindWindow("XLMAIN", 0)
    If hWnd = 0 Then    ' 0 means Excel not running.
        Exit Sub
    Else
    ' Excel is running so use the SendMessage API
    ' function to enter it in the Running Object Table.
        SendMessage hWnd, WM_USER + 18, 0, 0
    End If
End Sub

I've tested it with a table of my own, and it works. (as long as excel is running with the my_excel.xlsx file open. It doesn't want to start excel, or open the file. but since this is what was asked for...

GComyn