from Access to Excel

R

rutica

Registered User.
Local time
Today, 06:48
Joined
Jan 24, 2008
Messages
87
Bob Larson helped me greatly with his code to go from Access to Excel. Everything works great and all the data is populated on one Excel tab.

Now, I'm trying to add a second Excel tab to that same spreadsheet if a user picks a certain report from a combo box.

Here is the code--the bottom part (highlighted in red) is where I am stuck.


'---------------------------------------------------------------------------------------
' Procedure : Send2Excel
' Author : Bob Larson
' Date : 5/25/2008
' Purpose : Send any single recordset form to Excel. This will not work with
' subforms.
' Use : You may freely use this code as long as the author information in
' this header remains intact
'---------------------------------------------------------------------------------------
Public Sub Send2Excel(qry As String, Optional strSheetName As String)
' qry is the name of the query you want to send to Excel
' strSheetName is the optional name of the sheet you want to name it to
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As Field
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
On Error GoTo err_handler

Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Set db = CurrentDb
Set qdf = db.QueryDefs(qry)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
'check to see if there is data. If not, display a message and exit the function
If rst.RecordCount = 0 Then
MsgBox "Your report selection returned no data", , "No data"
Exit Sub
End If

Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Add
ApXL.Visible = True

Set xlWSh = xlWBk.Worksheets("Sheet1")
If Len(strSheetName) > 0 Then
xlWSh.Name = Left(strSheetName, 34)
End If
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

'delete Sheet2 and Sheet3
xlWBk.Sheets(Array("Sheet2", "Sheet3")).Select
xlWBk.Sheets("Sheet3").Activate
ApXL.ActiveWindow.SelectedSheets.Delete

'name the tab with the report name
ApXL.Sheets("Sheet1").Name = Forms!frmEscalationReports!cboEscalation.Column(1)

' selects the first cell to unselect all cells
xlWSh.Range("A1").Select

'*************for users that select Report ID=13 *************************
'if user selects Report ID=13, then need a new tab.
If Forms!frmEscalationReports!cboEscalation.Column(0) = 13 Then
ApXL.Sheets.Add
ApXL.Sheets("Sheet4").Select
ApXL.Sheets("Sheet4").Move After:=ApXL.Sheets(ApXL.Worksheets.Count)
ApXL.Sheets("Sheet4").Select
ApXL.Sheets("Sheet4").Name = "Codes by Category"
End If

'the new tab should contain the data in strSQL
Dim strSQL As String
strSQL = "SELECT tblEscalationReportsDetail.[Criteria Code], [KPI Rating Criteria].[Criteria Description], tblEscalationReportsDetail.CodeGrouping AS Category " & _
"FROM tblEscalationReportsDetail INNER JOIN [KPI Rating Criteria] ON tblEscalationReportsDetail.[Criteria Code] = [KPI Rating Criteria].[Criteria Code] " & _
"WHERE (((tblEscalationReportsDetail.ReportIDLink)=13)); "

'This is where I get stuck. I created and named this new tab. Now how do I populate it with the data from strSQL above?





rst.Close
Set rst = Nothing

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

Thanks!
 
this code is run in access? If so, have you tried the docmd.TransferSpreadsheet command? Or even the TransferText...
 
Ok at the part where you are stuck you need to pass the sql to a recordset and test for EOF. If not - some records exist, you can use the CopyFromRecordset Rs command used earlier.

at tip would not to delete sheet 2 unless the above returns no records. Why go through the motions of deleting a sheet to only have to add a new one after.

David
 
Thanks to both of you for writing.

YevS: Yes, the code is in Access. I tried Docmd.TransferSpreadsheet, but one of the required arguments is FileName which is the name of the text file to export to. The full path is required and it is a required argument. I don't have the path since my Excel file is unnamed (Book1).

DCrake: would I have to define a whole new set of variables?
This is what I tried, but it gives: "Item not found in this collection". My attempts are in red at the bottom.

'---------------------------------------------------------------------------------------
' Procedure : Send2Excel
' Author : Bob Larson
' Date : 5/25/2008
' Purpose : Send any single recordset form to Excel. This will not work with
' subforms.
' Use : You may freely use this code as long as the author information in
' this header remains intact
'---------------------------------------------------------------------------------------
Public Sub Send2Excel(qry As String, Optional strSheetName As String)
' qry is the name of the query you want to send to Excel
' strSheetName is the optional name of the sheet you want to name it to
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As Field
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
On Error GoTo err_handler

Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Set db = CurrentDb
Set qdf = db.QueryDefs(qry)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
'check to see if there is data. If not, display a message and exit the function
If rst.RecordCount = 0 Then
MsgBox "Your report selection returned no data", , "No data"
Exit Sub
End If

Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Add
ApXL.Visible = True

Set xlWSh = xlWBk.Worksheets("Sheet1")
If Len(strSheetName) > 0 Then
xlWSh.Name = Left(strSheetName, 34)
End If
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

'delete Sheet2 and Sheet3
xlWBk.Sheets(Array("Sheet2", "Sheet3")).Select
xlWBk.Sheets("Sheet3").Activate
ApXL.ActiveWindow.SelectedSheets.Delete

'name the tab with the report name
ApXL.Sheets("Sheet1").Name = Forms!frmEscalationReports!cboEscalation.Column(1)

' selects the first cell to unselect all cells
xlWSh.Range("A1").Select

'*************for users that select Report ID=13 (Watch List)**************************
'if user selects Watch List (Report ID=13) then need a new tab.

If Forms!frmEscalationReports!cboEscalation.Column(0) = 13 Then
ApXL.Sheets.Add
ApXL.Sheets("Sheet4").Select
ApXL.Sheets("Sheet4").Move After:=ApXL.Sheets(ApXL.Worksheets.Count)
ApXL.Sheets("Sheet4").Select
ApXL.Sheets("Sheet4").Name = "Codes by Category"

'the new tab should contain the data in strSQL
Dim strSQL As String
strSQL = "SELECT tblEscalationReportsDetail.[Criteria Code], [KPI Rating Criteria].[Criteria Description], tblEscalationReportsDetail.CodeGrouping AS Category " & _
"FROM tblEscalationReportsDetail INNER JOIN [KPI Rating Criteria] ON tblEscalationReportsDetail.[Criteria Code] = [KPI Rating Criteria].[Criteria Code] " & _
"WHERE (((tblEscalationReportsDetail.ReportIDLink)=13)); "

Dim db2 As DAO.Database
Dim qdf2 As DAO.QueryDef
Dim rst2 As DAO.Recordset
Dim fld2 As Field
Dim prm2 As DAO.Parameter

Set db2 = CurrentDb
Set qdf2 = db2.QueryDefs(strSQL)
Set rst2 = qdf2.OpenRecordset

For Each fld2 In rst2.Fields
ApXL.ActiveCell = fld2.Name
ApXL.ActiveCell.Offset(0, 1).Select
Next

rst2.MoveFirst
xlWSh.Range("A2").CopyFromRecordset rst2
xlWSh.Range("1:1").Select
rst2.Close
Set rst2 = Nothing


End If


rst.Close
Set rst = Nothing

Exit Sub
err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Sub
End Sub
 
Unless I'm misunderstanding, if done with the first sheet you can add a second by just reallocating the variable by doing it again:

Set xlWBk = ApXL.Workbooks.Add
xlWBk.Name = "Whatever"
 
Hi Bob!

I'm trying to figure out how to populate the second tab. I am able to create and name the tab, but how do I populate it with the strSQL data?

Thanks,
 
rutica said:
Hi Bob!

I'm trying to figure out how to populate the second tab. I am able to create and name the tab, but how do I populate it with the strSQL data?

Thanks,
Click to expand...
Is it a new set of records from a different query?
 
Yes, it is a new set of records from a variable I define called strSQL. (see below in red).


'*************for users that select Report ID=13 (Watch List)**************************
'if user selects Watch List (Report ID=13) then need a new tab.

If Forms!frmEscalationReports!cboEscalation.Column(0) = 13 Then
ApXL.Sheets.Add
ApXL.Sheets("Sheet4").Select
ApXL.Sheets("Sheet4").Move After:=ApXL.Sheets(ApXL.Worksheets.Count)
ApXL.Sheets("Sheet4").Select
ApXL.Sheets("Sheet4").Name = "Codes by Category"

'the new tab should contain the data in strSQL
Dim strSQL As String
strSQL = "SELECT tblEscalationReportsDetail.[Criteria Code], [KPI Rating Criteria].[Criteria Description], tblEscalationReportsDetail.CodeGrouping AS Category " & _
"FROM tblEscalationReportsDetail INNER JOIN [KPI Rating Criteria] ON tblEscalationReportsDetail.[Criteria Code] = [KPI Rating Criteria].[Criteria Code] " & _
"WHERE (((tblEscalationReportsDetail.ReportIDLink)=13)); "
 
So you should be able to simply do:

Code: 
Public Sub Send2Excel(qry As String, Optional strSheetName As String)
' qry is the name of the query you want to send to Excel
' strSheetName is the optional name of the sheet you want to name it to
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As Field
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler

    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim prm As DAO.Parameter
    Set db = CurrentDb
    Set qdf = db.QueryDefs(qry)
    For Each prm In qdf.Parameters
        prm.Value = Eval(prm.Name)
    Next prm
    Set rst = qdf.OpenRecordset
    'check to see if there is data. If not, display a message and exit the function
    If rst.RecordCount = 0 Then
        MsgBox "Your report selection returned no data", , "No data"
        Exit Sub
    End If

    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Add
    ApXL.Visible = True

    Set xlWSh = xlWBk.Worksheets("Sheet1")
    If Len(strSheetName) > 0 Then
        xlWSh.Name = Left(strSheetName, 34)
    End If
    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

    'delete Sheet2 and Sheet3
    xlWBk.Sheets(Array("Sheet2", "Sheet3")).Select
    xlWBk.Sheets("Sheet3").Activate
    ApXL.ActiveWindow.SelectedSheets.Delete

    'name the tab with the report name
    ApXL.Sheets("Sheet1").Name = Forms!frmEscalationReports!cboEscalation.Column(1)

    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select

    '*************for users that select Report ID=13 (Watch List)**************************
    'if user selects Watch List (Report ID=13) then need a new tab.

    If Forms!frmEscalationReports!cboEscalation.Column(0) = 13 Then
        ApXL.Sheets.Add
        ApXL.Sheets("Sheet4").Select
        ApXL.Sheets("Sheet4").Move After:=ApXL.Sheets(ApXL.Worksheets.Count)
        ApXL.Sheets("Sheet4").Select
        ApXL.Sheets("Sheet4").Name = "Codes by Category"

        'the new tab should contain the data in strSQL
        Dim strSQL As String
        strSQL = "SELECT tblEscalationReportsDetail.[Criteria Code], [KPI Rating Criteria].[Criteria Description], tblEscalationReportsDetail.CodeGrouping AS Category " & _
                 "FROM tblEscalationReportsDetail INNER JOIN [KPI Rating Criteria] ON tblEscalationReportsDetail.[Criteria Code] = [KPI Rating Criteria].[Criteria Code] " & _
                 "WHERE (((tblEscalationReportsDetail.ReportIDLink)=13)); "

        [COLOR="Blue"]Set rst = CurrentDb.OpenRecordset(strSQL)[/COLOR]


[COLOR="blue"]        For Each fld In rst.Fields
            ApXL.ActiveCell = fld.Name
            ApXL.ActiveCell.Offset(0, 1).Select
        Next[/COLOR]

        rst.MoveFirst

        xlWSh.Range("A2").CopyFromRecordset rst
        xlWSh.Range("1:1").Select

        rst.Close
        Set rst = Nothing


    End If


    rst.Close
    Set rst = Nothing

    Exit Sub

err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Sub
End Sub
 
I'm getting 'Select method of Range class failed'.

It populates the second tab with the column headers, but then gives that message. No data gets populated....


Edit: What i mean is, no data other than the column headers gets populated.
 
Forgot we needed to also

Set xlWsh = ApXL.Worksheets("Codes by Category")

before doing so.
 
Almost there! it populates the tab with data, but then i get the message 'Object variable or With block variable not set'
 
Okay, need to get rid of one set of these:

rst.Close
Set rst = Nothing
 
You're my hero!!! it works perfectly. Thank you so much!
 
I am currently using Office 2003. There is talk about moving to Office 2007.

I read that the 'Output to Excel' no longer works in 2007. I read that Service Pack 2 fixes this, but I don't know if we will get SP2 right away.

Will the code I am using above still work using Office 2007 (no service pack installed)?

Thanks,
 
rutica said:
I am currently using Office 2003. There is talk about moving to Office 2007.

I read that the 'Output to Excel' no longer works in 2007. I read that Service Pack 2 fixes this, but I don't know if we will get SP2 right away.

Will the code I am using above still work using Office 2007 (no service pack installed)?

Thanks,
Click to expand...

Yes, the Report output to Excel is back in SP2. Output to Excel from other objects were never gone. But yes, the code you are using will work in 2007 as well.
 
thanks Bob. The code is working so nicely i was scared i would lose it!

Do you know if it's possible to keep my mdb file with Access 2007? I know User Level Security doesn't work with the new file type called ACCDB, but can I keep my mdb file with 2007 and not convert to ACCDB?

With my current 2003 database, i ran the User Level Security Wizard. I have a mdw file and a shortcut.bat file users need to click in order to open the database. The .bat file specifies the workgroup file switch to open the database. i don't want to lose all that when we move to 2007. I'm reading about security in 2007, but it's kind of confusing.

thanks
 
Yes, you can use the mdb file format in 2007 and retain your ULS. That does mean you won't be able to use many of the nice new features of 2007, but you can still work as usual.
 
thanks! my mind is at ease now.

You're the best!
 
You must log in or register to reply here.

Similar threads

Gasman
Solved Cannot see the wood for the trees :(
Replies
15
Views
614
Gasman
Gasman
N
VBA MS Access Error Handling
Replies
5
Views
720
Pat Hartman
P
N
Solved How to force MS Access display a primary key on the forms after entering data in the first field
Replies
6
Views
627
Pat Hartman
P
A
Solved Filtering (using VBA) a subform based on Option Buttons on main form
Replies
19
Views
746
CJ_London
C
H
How to insert some data from Excel spreadsheet and the other data from Access combo boxes
Replies
6
Views
608
Pat Hartman
P

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom