Export single rows from a query to excel using a template

[Ernesto]

hello all,

I know the subject line is long, but i wanted to be as descriptive as
i could possibly be. if you dont want to read my story skip to the
next paragraph. here was my story, i was looking for a piece of code
which could automatically extract individual lines/rows/records from a
query to Excel. But not just any Excel file, but a template. so after
days of searching and combining different codes here is what I came up
with.

Here is what the code does: using "qryTransferToPM", each row is
extracted to the following sheet Planning Data" in the following
workbook "Accessory Price Worksheet Templatev4_multiplerows.xls". It
then saves each workbook as "Product 1", "Product 2", "Product 3",
etc. It saves the files in the same location as the database.

by no means am I an expert or good at this. I created this code out of
necessity. so if you find a better way to write the below
code...please let me know.

Here is the code. Please provide comments/updates:

======================================================
Function GetPath(Filename As String) As String
GetPath = (Mid(Filename, 1, Len(Filename) - Len(Dir(Filename))))
End Function
======================================================
Option Compare Database
Sub querytoexcel()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim fld2 As DAO.Field
Dim objXL As Excel.Application
Dim objXLBook As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim intCol As Integer
Dim intRow As Integer
Dim intName As Integer

Set db = CurrentDb

'get data into recordset
Set rs = db.OpenRecordset("qryTransferToPM")
conPath = GetPath(db.Name)
'rs2 = rs

'launch excel
Set objXL = New Excel.Application

'Naming varible
intName = 0

Do Until rs.EOF
'create worksheet
Set objXLBook = objXL.Workbooks.Open(conPath & "Accessory Price
Worksheet Templatev4_multiplerows.xls")


'Set objWS = objXL.Sheets("qryTheQuery")

Set objWS = objXL.Sheets("Planning Data")
'copy data
'first field names
For intCol = 0 To rs.Fields.Count - 1
Set fld = rs.Fields(intCol)
objWS.Cells(1, intCol + 1) = fld.Name
Next intCol
intName = intName + 1
'then actual data
intRow = 2
'Do Until rs.EOF
For intCol = 0 To rs.Fields.Count - 1
objWS.Cells(intRow, intCol + 1) = _
rs.Fields(intCol).Value
Next intCol
rs.MoveNext
intRow = intRow + 1
'objXL.Sheets("Planning Data").Visible = False
objXLBook.SaveAs (conPath & "Product_" & intName & ".xls")
objXLBook.Close
Loop

'objXLBook.Close

End Sub
======================================================

 

[Nick X]

You can try to add some of this code. This builds an Excel spreadsheet from
a template, although it only does one worksheet. You can probably tweak it
to read in multiples. Thanks to John Nurick for providing the following link:

http://msdn.microsoft.com/library/d...html/14761fa3-19be-4742-9f91-23b48cd9228f.asp

Sub exportspreadsheet()
'On Error GoTo HandleError

Dim objXLApp As Object
Set objXLApp = CreateObject("Excel.Application")
'Make sure to add "Reference" for MS Excel
Dim objXLBook As Excel.Workbook

'get current user's "My Documents" folder
Dim GetMyDocuments As String
Dim oWSH As Object 'IWshShell
Set oWSH = CreateObject("WScript.Shell")
GetMyDocuments = oWSH.SpecialFolders("MyDocuments")

Dim db As DAO.Database
Set db = CurrentDb
conPath = [GetMyDocuments] & "\Billing_Backup\"

'delete the old spreadsheet
'Kill conPath & "MySpreadsheet.xls"

Dim MyDate, MyStr
MyDate = [Forms]![fcuts]![EndDate]
MyStr = Format(MyDate, "yyyymmdd")

' create a workbook from the template
Set objXLApp = New Excel.Application
Set objXLBook =
objXLApp.Workbooks.Open("C:\Db_Backend\UtilityBillingArchive.xlt")
objXLApp.Visible = False

objXLBook.SaveAs (conPath & [Forms]![fcuts]![UtilityAlias] & " - " &
"Period Ending " & MyStr & " - Saved_" & Format(Now(), "yyyymmddhhmm") &
".xls")
objXLBook.Close
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel10,
"qryExpToExc", conPath & [Forms]![fcuts]![UtilityAlias] & " - " & "Period
Ending " & MyStr & " - Saved_" & Format(Now(), "yyyymmddhhmm") & ".xls", True

MsgBox "Done!" & vbCrLf & vbCrLf & "Copy of Bill has been stored in ""My
Documents\Billing_Backup"""

'ProcDone:
'On Error Resume Next

' Let's clean up our act
Set qdf = Nothing
Set db = Nothing
Set rs = Nothing
Set objResultsSheet = Nothing
Set objXLBook = Nothing
Set objXLApp = Nothing
Set oWSH = Nothing


ExitHere:
'Exit Function
'HandleError:
'Select Case Err.Number
'Case 3265
'Resume Next
'Case 1004
'Set objXLBook = objXLApp.Workbooks.Open(conPath & "Generic.xlt")
'Resume Next
'Case 53
'Resume Next
'Case 75
'Resume Next
'Case Else
'MsgBox Err.Description, vbExclamation,"Error " & Err.Number
'End Select
'Resume ProcDone
End Sub