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
>-----Original Message-----
>Are you trying to copy sheet1 to sheet2 in the same
>workbook or copy sheet1 into a new workbook?
>
>>-----Original Message-----
>>I am trying to create a copy an excel sheet and give it
a
>new name (from a
>>button in Access).
>>The main code listed below, I have used before for
>extracting information
>>from Excel.
>>What I would like to know is how to convert the excel
>macro that I have
>>inserted into the code to work with Access VBA.
>>
>>Any help would be greatly appreciated.
>>
>>
>>Private Sub copy_excel_sheet_Click()
>>Dim xlsApp As Object, xlsWB As Object, xlsWS As Object
>>Set xlsApp = CreateObject("Excel.Application")
>>Set xlsWB = xlsApp.Workbooks.Open("C:\excel_file.xls", ,
>True)
>> '
>> ' Excel Macro
>> '
>> Sheets("sheet1").Select
>> Sheets("sheet1").Copy After:=Sheets("sheet1")
>> Sheets("sheet1 (2)").Select
>> Sheets("sheet1 (2)").Name = "sheet2"
>> '
>>xlsWB.Close False
>>Set xlsWB = Nothing
>>xlsApp.Quit
>>Set xlsApp = Nothing
>>End Sub
>>
>>
>>.
>>
>.
>
|
Similar Threads
