Copy and paste are designed to be manual operations. While it is sometimes
useful to programmatically put stuff on the clipboard, the paste part of the
operation always assumes the correct position is set in the user interface,
so it's very difficult to get right with code.
The best way to do this is with automation. You open a recordset based on
your query, and open the Excel worksheet using code, then write the values
from your recordset into the appropriate cells.
I happen to have a function that does all of this, so you should be able to
use it with very little modification.
Just copy and paste the code into a module and call it like this:
Call ExportToExcel( "Name of query", "name of Excel file", "A2" )
You can choose values for the other optional arguments.
I hope you don't have too much trouble with line wrapping in the newsreader
--
Good Luck!
Graham Mandeno [Access MVP]
Auckland, New Zealand
================= start code =====================
#Const EarlyBinding = 0
' set this to 1 and add a reference to Excel when developing
Public Function ExportToExcel( _
Source As Variant, _
FileName As String, _
Optional SheetName As String, _
Optional StartRange As String, _
Optional Headers As Boolean = True, _
Optional OverWrite As VbMsgBoxResult, _
Optional ViewResult As Boolean = True) _
As Boolean
Const cFuncName = "ExportToExcel"
#If EarlyBinding Then
Dim oXL As Excel.Application
Dim oWkb As Excel.Workbook
Dim oSht As Excel.Worksheet
Dim oRng As Excel.Range
#Else
Dim oXL As Object
Dim oWkb As Object
Dim oSht As Object
Dim oRng As Object
#End If
Dim rs As Recordset, sMsg As String
Dim i As Integer, iRows As Integer, iCols As Integer
Dim iStartRow As Integer, iStartCol As Integer
Dim fRSOpened As Boolean, fNewFile As Boolean
Dim fHadErr As Boolean
'On Error GoTo ProcErr
Select Case VarType(Source)
Case vbString
Set rs = CurrentDb.OpenRecordset(Source)
fRSOpened = True
Case vbDataObject
If TypeOf rs Is DAO.Recordset Then
Set rs = Source
If Not rs.BOF Then rs.MoveFirst
End If
End Select
If rs Is Nothing Then Err.Raise vbObjectError, _
cFuncName, "Invalid source parameter"
With rs
If .RecordCount = 0 Then Err.Raise vbObjectError, _
cFuncName, "No records to export"
.MoveLast
.MoveFirst
iRows = .RecordCount
iCols = .Fields.Count
End With
Set oXL = CreateObject("Excel.Application")
If Len(Dir(FileName)) <> 0 Then
Set oWkb = oXL.Workbooks.Open(FileName)
If Len(SheetName) Then
If ObjectExists(oWkb.Worksheets, SheetName) Then
If OverWrite = 0 Then
sMsg = "Worksheet " & SheetName & " already exists in " _
& FileName & vbCrLf & vbCrLf _
& "Do you want to overwrite the data that is there?"
OverWrite = MsgBox(sMsg, vbYesNo Or vbQuestion _
Or vbDefaultButton2, "Overwrite data?")
End If
If OverWrite <> vbYes Then GoTo ProcEnd
Set oSht = oWkb.Worksheets(SheetName)
Else
Set oSht = oWkb.Worksheets.Add
oSht.Name = SheetName
End If
Else
Set oSht = oWkb.Worksheets.Add
End If
Else
fNewFile = True
oXL.SheetsInNewWorkbook = 1
Set oWkb = oXL.Workbooks.Add
Set oSht = oWkb.ActiveSheet
If Len(SheetName) Then oSht.Name = SheetName
End If
If Len(StartRange) = 0 Then StartRange = "A1"
With oSht
Set oRng = .Range(StartRange)
iStartRow = oRng.Row
iStartCol = oRng.Column
Set oRng = .Range(.Cells(iStartRow, iStartCol), _
.Cells(iStartRow + iRows - 1 - Headers, iStartCol + iCols - 1))
End With
With oRng
If Headers Then
For i = 1 To iCols
oRng(1, i) = rs.Fields(i - 1).Name
Next
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
End If
oRng(IIf(Headers, 2, 1), 1).CopyFromRecordset rs
For i = 7 To 12
.Borders(i).Weight = xlThin
Next
For i = 1 To iCols
Select Case rs.Fields(i - 1).Type
Case dbCurrency
.Columns(i).Style = "Currency"
End Select
Next
.Columns.AutoFit
End With
If fNewFile Then
oWkb.SaveAs FileName
Else
oWkb.Save
End If
ExportToExcel = True
ProcEnd:
On Error Resume Next
If fRSOpened Then rs.Close
If ViewResult And Not fHadErr Then
oXL.Visible = True
oXL.UserControl = True
Else
oXL.DisplayAlerts = False
oXL.Quit
End If
Set oWkb = Nothing
Set oXL = Nothing
Exit Function
ProcErr:
With Err
MsgBox .Description, vbExclamation, _
"Error #" & .Number & " in " & .Source
fHadErr = True
Resume ProcEnd
End Function
Public Function ObjectExists(col As Object, member As String) _
As Boolean
Dim O As Object
On Error Resume Next
Set O = col(member)
If Err Then
Err.Clear
Else
ObjectExists = True
Set O = Nothing
End If
End Function
============== end code ===========================
