Export Current Record to Excel

[knownote]

Hello All,

Using a form with a subform, how to export only the
current record (and related subrecord) to Excel, as I
already do with Word? The following code gives error

Run-time error '3061': Too few parameters. Expected 1.


Code----

Private Sub cmdExcel_Click()
Dim dbmain As DAO.Database
Dim rec_members As DAO.Recordset
Dim rec_report As DAO.Recordset
Dim XL_app As Excel.Application
Dim XL_book As Workbooks
Dim XL_sheet As Worksheet
Dim str_mem_SQL As String
Dim str_rep_SQL As String
Dim int_member As Double
Dim intR, IntC As Integer

Set dbmain = CurrentDb()

'--------- Set up workbook ---------------------
Set XL_app = New Excel.Application
Set XL_book = XL_app.Workbooks
XL_book.Add

'------------

str_mem_SQL = "SELECT * from qdfAll2 "


Set rec_members = dbmain.OpenRecordset(str_mem_SQL)

rec_members.MoveFirst

Do Until rec_members.EOF = True
intR = 4
IntC = 2

int_member = rec_members![CustomerID]

str_rep_SQL = "SELECT * from qdfAll where qdfAll2.tblClients.CustomerID = qdfAll.tblClients.CustomerID "
Set rec_report = dbmain.OpenRecordset(str_rep_SQL)
rec_report.MoveFirst
Set XL_sheet = XL_book(1).Worksheets.Add

With XL_sheet
.Name = int_member
.Range("B2").Value = rec_report![Subgect]
.Range("B3").Value = rec_report![CustomerID]
.Range("b4").Value = rec_report![Concerning]
.Range("B5").Value = rec_report![SubjectInfo]

.Range("B7").Value = rec_report![Todo]
.Range("C7").Value = rec_report![Status"]
.Range("D7").Value = rec_report![Category]
.Range("E7").Value = rec_report![DocLink]
.Range("F7").Value = rec_report![Account]
.Range("G7").Value = rec_report![Essence]
.Range("H7").Value = rec_report![AreaCode]
.Range("I7").Value = rec_report![WebSite]
.Range("J7").Value = rec_report![Address]
.Range("K7").Value = rec_report![City]
.Range("L7").Value = rec_report![State]
End With

Do Until rec_report.EOF = True
With XL_sheet
.Cells(intR, IntC + 1).Value = rec_report![Subgect]
.Cells(intR, IntC + 2).Value = rec_report![CustomerID]
.Cells(intR, IntC + 3).Value = rec_report![Concerning]
.Cells(intR, IntC + 4).Value = rec_report![SubjectInfo]
.Cells(intR, IntC + 5).Value = rec_report![Todo]
.Cells(intR, IntC + 6).Value = rec_report![Status]
.Cells(intR, IntC + 7).Value = rec_report![Category]
.Cells(intR, IntC + 8).Value = rec_report![DocLink]
.Cells(intR, IntC + 9).Value = rec_report![Account]
.Cells(intR, IntC + 10).Value = rec_report![Essence]
.Cells(intR, IntC + 11).Value = rec_report![AreaCode]
.Cells(intR, IntC + 12).Value = rec_report![WebSite]
.Cells(intR, IntC + 13).Value = rec_report![Address]
.Cells(intR, IntC + 14).Value = rec_report![City]
.Cells(intR, IntC + 15).Value = rec_report![State]

End With
intR = intR + 1
rec_report.MoveNext
Loop

With XL_sheet
.Columns("K:L").EntireColumn.Hidden = True
.Range("B7:J7").Font.Bold = True
.Range("B7:J7").Interior.ColorIndex = 15

With .Range("B2:B5")
.HorizontalAlignment = xlLeft
.Font.Name = "Arial"
.Font.Size = 11
.Font.Bold = True
End With

With .PageSetup
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

.Columns("B:B").ColumnWidth = 9.43
.Columns("C:C").ColumnWidth = 44.14
.Columns("D").ColumnWidth = 10.29
.Columns("E:E").ColumnWidth = 16.29
.Columns("F:F").ColumnWidth = 16.57
.Columns("G:G").ColumnWidth = 10.57
.Columns("H:H").ColumnWidth = 16.44
.Columns("I:I").ColumnWidth = 11.29
.Columns("J:J").ColumnWidth = 13.29

End With

rec_members.MoveNext

Loop
XL_app.DisplayAlerts = False
XL_book(1).Worksheets("SHEET1").Delete
XL_book(1).Worksheets("SHEET2").Delete
XL_book(1).Worksheets("SHEET3").Delete

End Sub

 

[PHV]

Is by chance qdfAll2 a parametized query ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[RoyVidar]

That error is often caused by the query being parameterized, or typos in the criteria part of the query, I guess there's something wrong with qdfAll2.tblClients.CustomerID, which should probably be either

qdfAll2.CustomerID

Likewise with the other side

But, wouldn't a join work better?

SELECT * from qdfAll inner joing qdfAll2 on qdfAll.CustomerID = qdfAll2.CustomerID

Roy-Vidar

 

[knownote]

Thanks PHV and Roy-Vidar

My bad. qdfAll is the query (of tblClients and
tblContacts) for all form and subform fields. qdfAll2
was merely a backup copy I didn't need.

I can export 3 variations to Word - the current (entire)
record, (entire) subrecord, and a combination of fields
from the main (tblClients) and subform (tblContacts)
using a query (qdfAll) to restrict records to current
Subgect (tblClients primary key, text). (tblContacts primary key is ContactID, autonumber. Both tables also
share CustomerID for master/child purposes -
AutoNumber in tblClients; Number in tblContacts.

The main form with a subform, frmClients, opens a
third form, frmCustomer, using query qdfAll to only
show the current subject's traits as such:
If IsLoaded("frmCustomer") = False Then
DoCmd.OpenForm "frmCustomer", , , "tblClients.CustomerID = " & Me.CustomerID, , acDialog
End If

How can I "translate" this function from Word to Excel?
Thanks
John

 

[PHV]

How can I "translate" this function from Word to Excel
Which function ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[knownote]

Since I use this query qdfall for more than 1 query
(single field, multiple field, city, date range), can I
also use it for Excel, adjusting this portion of the
select statements in the above code (str_rep_SQL and
str_mem_SQL without making a second copy of qdfAll query?


str_mem_SQL = "SELECT * from qdfAll2 "


Set rec_members = dbmain.OpenRecordset(str_mem_SQL)

rec_members.MoveFirst

Do Until rec_members.EOF = True
intR = 4
IntC = 2

int_member = rec_members![CustomerID]

str_rep_SQL = "SELECT * from qdfAll where qdfAll2.tblClients.CustomerID = qdfAll.tblClients.CustomerID "
Set rec_report = dbmain.OpenRecordset(str_rep_SQL)
rec_report.MoveFirst
Set XL_sheet = XL_book(1).Worksheets.Add

 

[PHV]

qdfAll2
was merely a backup copy I didn't need
So, why reposting the wrong code ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[knownote]

Sorry for rushing my last post. I need 3 variations of
Select statements: for frmClients, frmContacts, and
frmCustomers. I'll adapt the last 2 from the first. For
frmClients, should the Select statement be:

str_rep_SQL = "SELECT * from qdfAll where qdfAll.tblClients.CustomerID = tblClients.CustomerID "
or
qdfAll.tblClients.CustomerID = & Me.CustomerID " ?

I must occasionally start a thread (as I am not a
programmer), usually because of syntax.
Thanks
John

 

[PHV]

str_rep_SQL = "SELECT * FROM qdfAll WHERE tblClients.CustomerID = " & Me.CustomerID

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[knownote]

Thanks PHV
From a command button on frmClients using your Select
statement, I got
Run-time error '3265': Item not found in this collection.

Does item refer to a field or an object? I already had
a reference to Microsoft Excel 9.0 Object Library.
I am testing this code with only 4 frmClients fields.
I am using Access 97 (and also convert to Access 2000).

Code:
Private Sub cmdExcel_Click()
Dim dbmain As DAO.Database
Dim rec_members As DAO.Recordset
Dim rec_report As DAO.Recordset
Dim XL_app As Excel.Application
Dim XL_book As Workbooks
Dim XL_sheet As Worksheet
Dim str_mem_SQL As String
Dim str_rep_SQL As String
Dim int_member As Double
Dim intR, IntC As Integer

Set dbmain = CurrentDb()

'--------- Set up workbook ---------------------
Set XL_app = New Excel.Application
Set XL_book = XL_app.Workbooks
XL_book.Add

'------------

str_mem_SQL = "SELECT * FROM qdfAll "


Set rec_members = dbmain.OpenRecordset(str_mem_SQL)

rec_members.MoveFirst

Do Until rec_members.EOF = True
intR = 8
IntC = 2

int_member = rec_members![CustomerID]

str_rep_SQL = "SELECT * FROM qdfAll WHERE tblClients.CustomerID = " & Me.CustomerID
Set rec_report = dbmain.OpenRecordset(str_rep_SQL)
rec_report.MoveFirst
Set XL_sheet = XL_book(1).Worksheets.Add

With XL_sheet
.Name = int_member
.Range("B2").Value = rec_report![Subgect]
.Range("B3").Value = rec_report![CustomerID]
.Range("b4").Value = rec_report![Concerning]
.Range("B5").Value = rec_report![SubjectInfo]

End With

Do Until rec_report.EOF = True
With XL_sheet
.Cells(intR, IntC + 1).Value = rec_report![Subgect]
.Cells(intR, IntC + 2).Value = rec_report![CustomerID]
.Cells(intR, IntC + 3).Value = rec_report![Concerning]
.Cells(intR, IntC + 4).Value = rec_report![SubjectInfo]

End With
intR = intR + 1
rec_report.MoveNext
Loop

With XL_sheet
.Columns("K:L").EntireColumn.Hidden = True
.Range("B7:J7").Font.Bold = True
.Range("B7:J7").Interior.ColorIndex = 15

With .Range("B2:B5")
.HorizontalAlignment = xlLeft
.Font.Name = "Arial"
.Font.Size = 11
.Font.Bold = True
End With

With .PageSetup
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

.Columns("B:B").ColumnWidth = 9.43
.Columns("C:C").ColumnWidth = 44.14
.Columns("D").ColumnWidth = 10.29
.Columns("E:E").ColumnWidth = 16.29
.Columns("F:F").ColumnWidth = 16.57
.Columns("G:G").ColumnWidth = 10.57
.Columns("H:H").ColumnWidth = 16.44
.Columns("I:I").ColumnWidth = 11.29
.Columns("J:J").ColumnWidth = 13.29

End With

rec_members.MoveNext

Loop
XL_app.DisplayAlerts = False
XL_book(1).Worksheets("SHEET1").Delete
XL_book(1).Worksheets("SHEET2").Delete
XL_book(1).Worksheets("SHEET3").Delete

End Sub

 

[knownote]

On my main menu, I have the following code that opens the
Excel Open dialog box, using an existing or creating a
new instance of Excel. Could I somehow combine the below
code with the code in my previous post to improve
exporting the current record and/or subrecord to Excel?

code:

Public Sub cmdExcel_Click()
' credit "vbslammer" - Open Excel worksheet from Access

On Error Resume Next

Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim sht As Excel.Worksheet

Set xl = GetObject(, "Excel.Application")
If err.Number <> 0 Then
Set xl = CreateObject("Excel.Application")
'Else: Set xl = New Excel.Application 'instantiate Excel
End If

xl.Visible = True

' use Excel's built-in open dialog

xl.Dialogs(xlDialogOpen).Show "C:\*.xls"
Set wb = xl.ActiveWorkbook

' put appropriate sheet name/index here.

Set sht = wb.Sheets(1)

' tinker with range properties

'With sht
' With .Range("E20", "G20")
' .Merge
' .Value = "Merged Cells"
' .HorizontalAlignment = xlHAlignCenter
' .Font = "Comic Sans"
' .Font.Size = 18
' .Font.Bold = True
' .Interior.ColorIndex = 27
' End With
' .Activate
'End With

' do more stuff...

End Sub

 

[PHV]

...
str_mem_SQL = "SELECT DISTINCT CustomerID FROM qdfAll"
Set rec_members = dbmain.OpenRecordset(str_mem_SQL)
Do Until rec_members.EOF = True
intR = 8
IntC = 2
int_member = rec_members![CustomerID]
str_rep_SQL = "SELECT * FROM qdfAll WHERE CustomerID = " & int_member
Set rec_report = dbmain.OpenRecordset(str_rep_SQL)
Set XL_sheet = XL_book(1).Worksheets.Add
With XL_sheet
.Name = int_member
.Range("B2").Value = rec_report![Subgect]
.Range("B3").Value = rec_report![CustomerID]
.Range("B4").Value = rec_report![Concerning]
.Range("B5").Value = rec_report![SubjectInfo]
Do Until rec_report.EOF = True
.Cells(intR, IntC + 1).Value = rec_report![Subgect]
.Cells(intR, IntC + 2).Value = rec_report![CustomerID]
.Cells(intR, IntC + 3).Value = rec_report![Concerning]
.Cells(intR, IntC + 4).Value = rec_report![SubjectInfo]
intR = intR + 1
rec_report.MoveNext
Loop
rec_report.Close
Set rec_report = Nothing
.Columns("K:L").EntireColumn.Hidden = True
.Range("B7:J7").Font.Bold = True
.Range("B7:J7").Interior.ColorIndex = 15
With .Range("B2:B5")
.HorizontalAlignment = xlLeft
.Font.Name = "Arial"
.Font.Size = 11
.Font.Bold = True
End With
With .PageSetup
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
.Columns("B:B").ColumnWidth = 9.43
.Columns("C:C").ColumnWidth = 44.14
.Columns("D").ColumnWidth = 10.29
.Columns("E:E").ColumnWidth = 16.29
.Columns("F:F").ColumnWidth = 16.57
.Columns("G:G").ColumnWidth = 10.57
.Columns("H:H").ColumnWidth = 16.44
.Columns("I:I").ColumnWidth = 11.29
.Columns("J:J").ColumnWidth = 13.29
End With
rec_members.MoveNext
Loop
rec_members.Close
Set rec_members = Nothing
...

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[knownote]

Some progress -
Item not found in this collection. (Error 3265)

An attempt to reference a name in a collection failed.
Possible causes:

· The object doesn't exist in this collection. Make sure the object is appended to a collection before referencing it.
· There is more than one object with this name in the collection; using its name is an ambiguous reference. Reference the object by its ordinal position in the collection (for example, Recordsets(3))

Preceding the 4 fields with tblClient. didn't help.

 

[knownote]

I cut some formatting code, leaving just the main exporting
to Excel code (I think), but am still getting this:
Item not found in this collection. (Error 3265)

This code from this fora may be from a more recent version
of Access; does any method or properties not "belong"
to Access 97?

---- Code: (Access 97, and eventually Access 2000)

Private Sub cmdExcel_Click()
Dim dbmain As DAO.Database
Dim rec_members As DAO.Recordset
Dim rec_report As DAO.Recordset
Dim XL_app As Excel.Application
Dim XL_book As Workbooks
Dim XL_sheet As Worksheet
Dim str_mem_SQL As String
Dim str_rep_SQL As String
Dim int_member As Double
Dim intR, IntC As Integer

Set dbmain = CurrentDb()

'--------- Set up workbook ---------------------
Set XL_app = New Excel.Application
Set XL_book = XL_app.Workbooks
XL_book.Add

'------------

str_mem_SQL = "SELECT DISTINCT CustomerID FROM qdfAll"
Set rec_members = dbmain.OpenRecordset(str_mem_SQL)

' rec_members.MoveFirst

Do Until rec_members.EOF = True
intR = 8
IntC = 2
int_member = rec_members![CustomerID]
str_rep_SQL = "SELECT * FROM qdfAll WHERE CustomerID = " & int_member
Set rec_report = dbmain.OpenRecordset(str_rep_SQL)
Set XL_sheet = XL_book(1).Worksheets.Add

With XL_sheet
.Name = int_member
.Range("B2").Value = rec_report![Subgect]
.Range("B3").Value = rec_report![CustomerID]
.Range("B4").Value = rec_report![Concerning]
.Range("B5").Value = rec_report![SubjectInfo]

' End With

Do Until rec_report.EOF = True
' With XL_sheet
.Cells(intR, IntC + 1).Value = rec_report![Subgect]
.Cells(intR, IntC + 2).Value = rec_report![CustomerID]
.Cells(intR, IntC + 3).Value = rec_report![Concerning]
.Cells(intR, IntC + 4).Value = rec_report![SubjectInfo]

' End With
intR = intR + 1
rec_report.MoveNext
Loop
rec_report.close
Set rec_report = Nothing

' cut formatting code

End With
rec_members.MoveNext
Loop
rec_members.close
Set rec_members = Nothing
XL_app.DisplayAlerts = False
XL_book(1).Worksheets("SHEET1").Delete
XL_book(1).Worksheets("SHEET2").Delete
XL_book(1).Worksheets("SHEET3").Delete

End Sub