Specific fields from Access to Excel VBA

[Neilster]

Hi

Does anyone know VBA for a click button that extracts specific fields in an Access DB in to an Excel spread sheet.

I've researched endlessly, appreciate any help. :banghead:

 

[Rx_]

Bookmark http://btabdevelopment.com/
http://btabdevelopment.com/code-snippets/page/2/
Review samples 2 through 5 and see if one suits your needs.

 

[Neilster]

Hi

Thanks for that, however stupid question - how do I call the module from a Private Sub cmdExportExcel_Click()

Thanks for your help.

 

[Rx_]

If it is a sub or function?
Is it in a stand-alone module or in a form / report module.
Basically, put the word Public only in front of the routine being called.

Public Function MyReport() as Boolean
to call a Function -
Dim MyResult as Boolean
MyResult = MyReport()

As a process, I typically set MyReport = False
This way, if there is an error, the calling routine gets a False back.
Inside the function - at the end - set MyReport = True

This way, you are calling a function. The function goes to create your excel, then reports back to the calling procedure with a True / False to indicate the status.

 

[Neilster]

Hi

I have put this code into a Module.

Public Function SendTQ2ExcelSheet(strTQName As String, strSheetName As String)

Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field
Dim strPath As String
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107

On Error GoTo err_handler
strPath = “”
Set rst = CurrentDb.OpenRecordset(strTQName)
Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Open(strPath)
ApXL.Visible = True

Set xlWSh = xlWBk.Worksheets(strSheetName)

xlWSh.Activate
xlWSh.Range("A1").Select

For Each fld In rst.Fields
ApXL.ActiveCell = fld.Name
ApXL.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst

xlWSh.Range("A2").CopyFromRecordset rst
xlWSh.Range("1:1").Select
With ApXL.Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With

ApXL.Selection.Font.Bold = True

With ApXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With


ApXL.ActiveSheet.Cells.Select


ApXL.ActiveSheet.Cells.EntireColumn.AutoFit


xlWSh.Range("A1").Select
rst.Close
Set rst = Nothing
Exit Function

err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Function
End Function

Therefore I would imagine in need to call the function from a private sub?

 

[Rx_]

Sorry I only had 4 minutes to offer these changes.
Put this in a module, yes.

Open the Immediate window (debugger). On the left column of the code, set some break points to walk through the code.
Note, due to time, I hard-coded the path to test and save.

In the Immediate window type:
? SendTQ2ExcelSheet("FIPS_State", "Rx")

The ? is a shortcut name for debug.print
In your calling code module, create a variable
MyExcelRunStatus as Boolean
MyExcelRunStatus =SendTQ2ExcelSheet("FIPS_State", "Rx")
FIPS_State was a table name in my Database - a table or query will do

Note, the function has a return value- if it makes it to the end with out errors, then the function will return a True - so your code can use that as an option to report "finished". Often, the Excel code should run with visible = false

I took the liberty of adding a date timestamp to the Excel save as. This way each report is identified.

Quick sidenote: in the Error Trap
add ApXL.Quit and destroy the record set variable (the same cleanup)
if the error trap is executed. That is one of the improvements needed.



This was a quick fix. It is good for a single Excel Worksheet.
Hopefully it gets you started and there can be many improvements from this example.

Option Compare Database
 
Public Function SendTQ2ExcelSheet(strTQName As String, strSheetName As String) As Boolean
 
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field
Dim strPath As String
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Dim strSaveAsFileName As String
 
On Error GoTo err_handler
strPath = "M:\Archives"  ' path for testing stuff put your own in
Set rst = CurrentDb.OpenRecordset(strTQName)
Set ApXL = CreateObject("Excel.Application")
    'Set ApXL = New Excel.Application
    ApXL.EnableEvents = False
    ApXL.Workbooks.Add
    ApXL.Worksheets.Add
'Set xlWBk = ApXL.Workbooks.Open(strPath) ' if existing exist
SendTQ2ExcelSheet = False
ApXL.Visible = True  ' after testing, this is usually set to false 
 
'Set xlWSh = xlWBk.Worksheets(strSheetName) ' we can deal with this later
ApXL.Range("A1").Select
 
For Each fld In rst.Fields
 ApXL.ActiveCell = fld.Name
 ApXL.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst
 
ApXL.Range("A2").CopyFromRecordset rst
ApXL.Range("1:1").Select
With ApXL.Selection.Font
 .Name = "Arial"
 .Size = 12
End With
 
ApXL.Selection.Font.Bold = True
 
With ApXL.Selection
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlBottom
End With
 
ApXL.ActiveSheet.Cells.Select
 
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
 
ApXL.Range("A1").Select
 
 With ApXL.ActiveSheet.PageSetup ' Your printer driver may vary
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        '.Orientation = xlPortrait  ' uncomment for this option
        .Draft = False
        .PaperSize = xlPaper11x17     'WARNING I LIKE BIG REPORTS comment out for your printers default
        .FirstPageNumber = xlAutomatic
        .Order = xlOverThenDown
        .BlackAndWhite = False
        '.Zoom = 56   ' uncomment if you need this
          .Zoom = False
          .FitToPagesWide = 1    ' Zoom to column width
          .FitToPagesTall = False  ' this use to be 0 but False works on the new Xerox printer
        '.PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        '.PrintTitleRows = "$1:$" & (intRowPos)        ' repeats header row 1 to 5 Removed -1 on introwposition due to double title.
        .LeftFooter = "Page &P of &N"
        .RightFooter = "&D"
 
      End With
 
    rst.Close
    Set rst = Nothing
 
    strSaveAsFileName = strPath & "\" & Format(Now(), "yyyy-mm-dd @ hhnnss") & ".xlsx"
 
      ApXL.ActiveWorkbook.SaveAs FileName:=strSaveAsFileName
      ApXL.Visible = False
      ApXL.Quit
 
SendTQ2ExcelSheet = True ' indicates to caller things passed
 
Exit Function
 
err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Function
End Function

Good luck!

 

[Neilster]

Ok That's Fine and thanks for the code, however I have a button on a form called Sales form that comes from SalesTbl.

On the form I have a button called export to excel, what code do I need to put in the click event?

 

[Neilster]

I have now sorted it out.

I just need to know how to select certain fields from my Access form into excel?

 

[Neilster]

And I get a message saying "Invalid data value for parameter"

 

[Cronk]

You could be helpful by stating on which line you are getting the error message.

However it could be

Set xlWBk = ApXL.Workbooks.Open(strPath)

because you have set strPath as a zero length string whereas Excel is expecting a valide file name (including path)
eg strPath ="C:\YourFolder\YourSpreadsheet.xlsx"

Take the advice offered earlier and step through your function line at a time.