Ross, here are 2 sample modules. The first copies data
from a query into multiple sheets. The second opens a
excel file (template) then loads data into new sheets and
saves them into separate workbooks. You need to have the
Excel 9.0 Object Library reference turned on.
Sample 1)
Function Tbl_Qry_To_Excel()
Dim objExcel As Excel.Application
Dim objSheet As Excel.Worksheet
Dim objBook As Excel.Workbook
Dim j As Long, i As Integer, K As Integer
Dim fld1 As String, dblSum As Double
Dim tbl1 As New ADODB.Recordset
Dim cn As New ADODB.Connection
' Create a new instance of Excel workbook and sheet.
Set objExcel = CreateObject("Excel.Application")
Set objBook = objExcel.Workbooks.Add
Set objSheet = objBook.Worksheets.Add(, , 9)
Set cn = CurrentProject.Connection
' Set variables to zero.
j = 0
i = 0
K = 0
fld1 = "c:\temp\xltext" & Format(Time(), "hhnnss")
& ".xls"
' Turn off Access warning messages.
DoCmd.SetWarnings False
' Do you want to see Excel on screen?
If MsgBox("Do you want Excel visible?", vbInformation
+ vbYesNo, _
"Application Visible?") = vbYes Then
' Show the instance of Excel on the screen.
objExcel.Visible = True
End If
' Open query an save as recordset.
tbl1.Open "Query1", cn, adOpenKeyset, adLockOptimistic
' How many records in recordset?
j = tbl1.RecordCount
' Open, copy recordset then format worksheet.
For K = 1 To 3
tbl1.MoveFirst
'objBook.Sheets(K).Select.
With objBook.Sheets(K)
' Make this sheet active.
.Activate
.Shapes.AddPicture "c:\temp\5_1.bmp", False, True,
140, 2, 63, 32
.Range("a5").CopyFromRecordset tbl1
.Range("a4").Value = "Creditor Name"
.Range("a4").Interior.ColorIndex = 5
.Range("a4").Font.ColorIndex = 2
.Range("a4").Font.Bold = True
.Range("b4").Value = "Invoice#"
.Range("b4").Interior.ColorIndex = 3
.Range("b4").Font.Bold = True
.Range("c4").Value = "LC Amount"
.Range("c4").Interior.ColorIndex = 4
.Range("c4").Font.Bold = True
dblSum = .Application.WorksheetFunction.Sum(.Range
("c5:c" & j + 4))
.Range("b" & j + 6).Value = "Sum"
.Range("c" & j + 6).Value = dblSum
.Range("b" & j + 6 & ":c" & j + 6).Font.Bold = True
.Range("b" & j + 6 & ":c" & j + 6).Interior.ColorIndex
= 28
.Range("b4").HorizontalAlignment = xlCenter
.Range("c4").HorizontalAlignment = xlCenter
.Range("a4:c" & j + 4).Borders.ColorIndex = 1
.Range("b" & j + 6 & ":c" & j + 6).Borders.ColorIndex
= 1
.Rows("4").RowHeight = 20
.Rows("4").VerticalAlignment = xlCenter
.Columns("a:b").AutoFit
.Columns("c").ColumnWidth = 20
.Name = "Answer" & K
End With
Next K
' Make first sheet active.
objBook.Sheets(1).Activate
tbl1.Close
' How many sheets are there?
i = objBook.Sheets.Count
K = 0
' Turn off Excel alert messages.
objExcel.DisplayAlerts = False
For j = i To 1 Step -1
For K = 1 To i
If objBook.Sheets(j).Name = "Sheet" & K Then
objBook.Sheets(j).Delete
K = i
End If
Next K
Next j
' Turn on Excel alert messages.
objExcel.DisplayAlerts = True
' Save the Workbook.
objBook.SaveAs fld1
' Close the Workbook.
objBook.Close
' Close Excel to free up memory.
objExcel.Quit
' Set the variable to Nothing to free up the name
' space in Access.
Set tbl1 = Nothing
Set objExcel = Nothing
Set objSheet = Nothing
Set objBook = Nothing
' Turn on Access warning messages.
DoCmd.SetWarnings True
MsgBox "Done! File saved as:" & vbCrLf & vbCrLf & fld1
End Function
Sample 2)
Function Tbl_Qry_To_Excel_2()
Dim objExcel As Excel.Application
Dim objSheet As Excel.Worksheet
Dim objBook As Excel.Workbook
Dim j As Long, i As Integer, K As Integer, JJ As
Integer
Dim fld1 As String, dblSum As Double
Dim tbl1 As New ADODB.Recordset
Dim cn As New ADODB.Connection
' Create a new instance of Excel workbook and sheet.
Set objExcel = CreateObject("Excel.Application")
Set objBook = objExcel.Workbooks.Open
("c:\temp\xltexttemp.xlt")
Set objSheet = objBook.Worksheets(1)
Set cn = CurrentProject.Connection
' Set variables to zero.
j = 0
i = 0
K = 0
JJ = 0
fld1 = "c:\temp\xltext" & Format(Time(), "hhnnss")
& ".xls"
' Turn off Access warning messages.
DoCmd.SetWarnings False
' Do you want to see Excel on screen?
If MsgBox("Do you want Excel visible?", vbInformation
+ vbYesNo, _
"Application Visible?") = vbYes Then
' Show the instance of Excel on the screen.
objExcel.Visible = True
End If
' Open query an save as recordset.
tbl1.Open "Query1", cn, adOpenKeyset, adLockOptimistic
' How many records in recordset?
j = tbl1.RecordCount
' Copy template into three (3) new workbooks.
For K = 27 To 29
objBook.SaveCopyAs "c:\temp\xltext" & K & ".xls"
Next K
' Close template.
objBook.Close
' Delay counter = 1 second
For K = 27 To 29
For i = 1 To 1000
Next i
' Open "saved" Workbook.
Set objBook = objExcel.Workbooks.Open("c:\temp\xltext"
& K & ".xls")
Set objSheet = objBook.Worksheets(1)
tbl1.MoveFirst
' Open and copy recordset into Worksheet.
With objSheet
.Range("a5").CopyFromRecordset tbl1
dblSum = .Application.WorksheetFunction.Sum(.Range
("c5:c" & j + 4))
.Range("b" & j + 6).Value = "Sum"
.Range("c" & j + 6).Value = dblSum
.Range("b" & j + 6 & ":c" & j + 6).Font.Bold = True
.Range("b" & j + 6 & ":c" & j + 6).Interior.ColorIndex
= 28
.Range("a5:c" & j + 4).Borders.ColorIndex = 1
.Range("b" & j + 6 & ":c" & j + 6).Borders.ColorIndex
= 1
.Name = "Today at " & Format(Time(), "hhnnss")
End With
' How many sheets are there?
i = objBook.Sheets.Count
' Turn off Excel alert messages.
objExcel.DisplayAlerts = False
For JJ = i To 1 Step -1
If objBook.Sheets(JJ).Name = "Sheet" & JJ Then
objBook.Sheets(JJ).Delete
End If
Next JJ
' Turn on Excel alert messages.
objExcel.DisplayAlerts = True
' Save the Workbook.
objBook.Save
' Close the Workbook.
objBook.Close
Next K
tbl1.Close
' Close Excel to free up memory.
objExcel.Quit
' Set the variable to Nothing to free up the name
' space in Access.
Set tbl1 = Nothing
Set objExcel = Nothing
Set objSheet = Nothing
Set objBook = Nothing
' Turn on Access warning messages.
DoCmd.SetWarnings True
MsgBox "Done! Files saved is C:\Temp!"
End Function
