Exporting to specific Excel range

[boblarson]

What is the full SentTQ2Excel code you are using? Also, are you using an Excel file which has both sheets in there or are you trying to create a new one and both sheets don't currently exist and you are wanting them to? That is important to know in order to modify the code to fit your need.

 

[sparkyrose]

This is the Module:

Public Function SendTQ2ExcelSheet(strTQName As String, strSheetName As String, Optional strFilePath As String, Optional strRange As String, Optional blnIncludeHeaders As Boolean)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strRange is where you want the data to start.
 
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As Field
    Dim strPath As String
 
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler
 
 If strFilePath <> "" Then
        strPath = strFilePath
    End If
    Set rst = CurrentDb.OpenRecordset(strTQName)
    Set ApXL = CreateObject("Excel.Application")
    If strPath <> "" Then
        Set xlWBk = ApXL.Workbooks.Open(strPath)
    Else
        Set xlWBk = ApXL.Workbooks.Add
    End If
    ApXL.Visible = True
    If strSheetName <> "" Then
        Set xlWSh = xlWBk.Worksheets(strSheetName)
    Else
        Set xlWSh = xlWBk.Worksheets(1)
    End If
    If strRange <> "" Then
        xlWSh.Range(strRange).Select
    Else
        xlWSh.Range("A2").Select
    End If
    If blnIncludeHeaders Then
        For Each fld In rst.Fields
            ApXL.ActiveCell = fld.Name
            ApXL.ActiveCell.Offset(0, 1).Select
        Next
    End If
    rst.MoveFirst
    If strRange <> "" Then
        xlWSh.Range(strRange).CopyFromRecordset rst
    Else
        xlWSh.Range("A2").CopyFromRecordset rst
    End If
 
    'xlWSh.Range("A2:M25").Select
    ' This is included to show some of what you can do about formatting.  You can comment out or delete
    ' any of this that you don't want to use in your own export.
    'With ApXL.Selection.Font
    '    .Name = "Calibri"
     '   .Size = 11
      '  .Strikethrough = False
       ' .Superscript = False
    '    .Subscript = False
    '    .OutlineFont = False
    '    .Shadow = False
    'End With
    'ApXL.Selection.Font.Bold = False
    'With ApXL.Selection
    '    .VerticalAlignment = xlBottom
    '    .WrapText = False
    '    .Orientation = 0
    '    .AddIndent = False
    '    .IndentLevel = 0
    '    .ShrinkToFit = False
    '    .MergeCells = False
    'End With
    ' selects all of the cells
    'ApXL.ActiveSheet.Cells.Select
    ' does the "autofit" for all columns
    'ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
    ' selects the first cell to unselect all cells
    'xlWSh.Range("A1").Select
    rst.Close
    Set rst = Nothing
 
    'save and close Excel File
    ApXL.Application.DisplayAlerts = False
    ApXL.Application.Save
    ApXL.Application.DisplayAlerts = True
    ApXL.Application.Quit
 
    Set xlWSh = Nothing
    Set xlWkb = Nothing
    Set ApXL = Nothing
 
    Exit Function
err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Function
End Function

I tried adding your save and close language but I got an error message:

"424 Object Required"

Both sheets already existing the workbook.

Thanks!

 

[boblarson]

Okay, here's the corrected function (including my close code which works for me). I guess we had to activate the worksheet first.

Public Function aSendTQ2ExcelSheet(strTQName As String, strSheetName As String, Optional strFilePath As String, Optional strRange As String, Optional blnIncludeHeaders As Boolean)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strRange is where you want the data to start.
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As Field
    Dim strPath As String
 
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
 
        On Error GoTo err_handler
 
    If strFilePath <> "" Then
        strPath = strFilePath
    End If
 
    Set rst = CurrentDb.OpenRecordset(strTQName)
    Set ApXL = CreateObject("Excel.Application")
 
    If strPath <> "" Then
        Set xlWBk = ApXL.Workbooks.Open(strPath)
    Else
        Set xlWBk = ApXL.Workbooks.Add
    End If
 
    ApXL.Visible = True
 
    If strSheetName <> "" Then
        Set xlWSh = xlWBk.Worksheets(strSheetName)
    Else
        Set xlWSh = xlWBk.Worksheets(1)
    End If
 
    If strRange <> "" Then
        [B][COLOR=red]xlWSh.Activate[/COLOR][/B]
        xlWSh.Range(strRange).Select
    Else
        xlWSh.Range("A2").Select
    End If
 
    If blnIncludeHeaders Then
        For Each fld In rst.Fields
            ApXL.ActiveCell = fld.Name
            ApXL.ActiveCell.Offset(0, 1).Select
        Next
    End If
 
    rst.MoveFirst
 
    If strRange <> "" Then
        xlWSh.Range(strRange).CopyFromRecordset rst
    Else
        xlWSh.Range("A2").CopyFromRecordset rst
    End If
 
    rst.Close
    Set rst = Nothing
 
[B][COLOR=red]    'save and close Excel File[/COLOR][/B]
[B][COLOR=red]    xlWBk.Save[/COLOR][/B]
[B][COLOR=red]    ApXL.Application.Quit[/COLOR][/B]
 
    Set xlWSh = Nothing
    Set xlWBk = Nothing
    Set ApXL = Nothing
    Exit Function
 
err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Function
End Function

 

[sparkyrose]

Fantastic! works perfectly.

Thanks for all your help

 

[janeyg]

Dear Bob, I have a query which I have searched on and I can't find the right solution. I was looking at your codes (below and on your web page) but I dont understand how I can use or modify them to do this:-
I have a form that I can filter records on, the form also contains calculations, I set up an export in excel with the filtered records selected. This exports to excel - which works fine but as the calculatations are in the form, and I export from the form - the excel output includes the calculations. I dont know how to exclude those columns from apprearing. If I run the export from a query based on the form, I then don't know how to specify or write a code to export the filtered records selected in the form?

Really, I just want to be able to export from a form, the filtered records selected but not includes certain columns, like the calulation fields and possibly a notes field.

I thought your code may be what I am looking for but I dont understand it and when I try to apply it - it wont let me run the export whilst the form is open - which will be the case as when records are filtered, an export with then be performed on those records.
Can you help me at all? I am new to code and tend to work with existing codes and modify them, if they are basic.
thanks
Janeyg

 

[Notedop]

*edit, better use next posts code. this is not fully correct

If you need to clear the data sheet first before adding new data add the following code to the function:

This will clear all fields from the selected range down to last cell. Note that the kolomn name should be manually adjusted.

    xlWSh.Range(strRange & ":Z65536").Select
    ApXL.Selection.Clear

Place it before the following code:

    If strRange <> "" Then
        xlWSh.Activate
        xlWSh.Range(strRange).Select
    Else
        xlWSh.Range("A2").Select
    End If

I did notice an error when enabling the include headers. It writes the headers however overwrites them again when pasting the recordset values. So the strRange should be incremented by 1 when using headers. Not sure if there is an quick vba function to do this?

I think first need to select the strRange cell, then use the ApXL.ActiveCell.Offset(1, 0).Select code to select on row below, then read the currentcell and reset strRange to that cell number. However I don't have experience with excell VBA code so I'm not sure if this is manageable.

 

[Notedop]

Okay, did some little research, this seems to work:

*edit, adjusted code a bit

Public Function aSendTQ2ExcelSheet(strTQName As String, strSheetName As String, Optional strFilePath As String, Optional strRange As String, Optional blnIncludeHeaders As Boolean)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to
' strRange is where you want the data to start.
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As Field
    Dim strPath As String
 
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
 
        On Error GoTo err_handler
 
    If strFilePath <> "" Then
        strPath = strFilePath
    End If
 
    Set rst = CurrentDb.OpenRecordset(strTQName)
    Set ApXL = CreateObject("Excel.Application")
 
    If strPath <> "" Then
        Set xlWBk = ApXL.Workbooks.Open(strPath)
    Else
        Set xlWBk = ApXL.Workbooks.Add
    End If
 
    ApXL.Visible = True
 
    If strSheetName <> "" Then
        Set xlWSh = xlWBk.Worksheets(strSheetName)
    Else
        Set xlWSh = xlWBk.Worksheets(1)
    End If
    
'    xlWSh.Range(strRange & ":Z65536").Select
'    ApXL.Selection.Clear
    
    
    If strRange <> "" Then
        xlWSh.Activate
        xlWSh.Range(strRange & ":Z65536").Select
        ApXL.Selection.Clear
        xlWSh.Range(strRange).Select
    Else
        xlWSh.Range("A2").Select
    End If
 
    If blnIncludeHeaders Then
        For Each fld In rst.Fields
            ApXL.Activecell = fld.Name
            ApXL.Activecell.Offset(0, 1).Select
        Next
        xlWSh.Range(strRange).Select
        ApXL.Activecell.Offset(1, 0).Select
        strRange = ApXL.Activecell.Address
    End If
 
    rst.MoveFirst
 
    If strRange <> "" Then
        xlWSh.Range(strRange).CopyFromRecordset rst
    Else
        xlWSh.Range("A2").CopyFromRecordset rst
    End If
 
    rst.Close
    Set rst = Nothing
 
    'save and close Excel File
    xlWBk.Save
    ApXL.Application.Quit
 
    Set xlWSh = Nothing
    Set xlWBk = Nothing
    Set ApXL = Nothing
    Exit Function
 
err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.number
    Exit Function
End Function