I use the following to transfer data...
I generally write it/troubleshoot it using early binding then switch
to late binding for actual use.
The gist of it is to use excel's CopyFromRecordset method
Hope this helps
Tom
Public Sub subGenerateExcel(RowSQL As String, ShowFile As Boolean,
Optional FileName As String)
'---------------------------------------------------------------------------------------
' Name : subGenerateExcel
' DateTime : 6/4/2008 14:18
' Author : RT Mitchell
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim strRS As String
Dim strFilter As String
Dim rst As DAO.Recordset
Dim bolFlag As Boolean
'****early binding*************
'Dim objXL As Excel.Application
'Dim objWorkbk As Excel.Workbook
'Dim objWorkSht As Excel.Worksheet
'Set objXL = New Excel.Application 'early binding
'****late binding*****************
Dim objXL As Object, objWorkbk As Object, objWorkSht As Object
Set objXL = CreateObject("Excel.Application") 'late binding
'*********excel constants used with late binding
Const xlContinuous As Long = 1
Const xlThin As Long = 2
Const xlAutomatic As Long = -4105
Const xlsolid As Long = 1
Const xlEdgeLeft As Long = 7
Const xlEdgeRight As Long = 10
Const xlEdgeTop As Long = 8
Const xlEdgeBottom As Long = 9
Const xlInsideVertical As Long = 11
Const xlInsideHorizontal As Long = 12
Const xlCenter As Long = -4108
Const xlAllChanges As Long = 2
Const xlValidateList As Long = 3
Const xlValidAlertStop As Long = 1
Const xlBetween As Long = 1
Const xlUnlockedCells As Long = 1
Const xlshared As Long = 2
On Error GoTo ErrHandler
Set rst = CurrentDb.OpenRecordset(RowSQL, dbOpenDynaset, dbSeeChanges)
Set objWorkbk = objXL.Workbooks.Add
Set objWorkSht = objWorkbk.Worksheets("Sheet1")
With objWorkSht.Range("A1")
.offset(0, 0).Value = "Item No"
.offset(0, 1).Value = "Due Date"
.offset(0, 2).Value = "Forecast Date"
.offset(0, 3).Value = "Responsible Individual"
.offset(0, 4).Value = "Secondary Individual"
.offset(0, 5).Value = "Status"
.offset(0, 6).Value = "Audit Binder"
.offset(0, 7).Value = "Agency"
.offset(0, 8).Value = "Citation"
.offset(0, 9).Value = "Permit/Approval/Notification"
.offset(0, 10).Value = "Info Requirement"
.offset(0, 11).Value = "Deliverable"
.offset(0, 12).Value = "Remarks"
'export data
.offset(1, 0).CopyFromRecordset rst
'do the lines
End With
With objWorkSht.UsedRange
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'do the formats
.Columns.AutoFit
End With
'apply color
With objWorkSht.Range("A1:M1").Interior
.ColorIndex = 37
.Pattern = xlsolid
End With
'add validation to the status column
With objWorkSht.Range("F:F").Validation
.Add xlValidateList, xlValidAlertStop, xlBetween, "Not Started, In
Progress, Hold, Delivered"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = "Status List"
.ErrorTitle = "Status List"
.InputMessage = "Select an updated status from the drop down list."
.ErrorMessage = "You must select one of the listed items for the
Status. Click Cancel to continue."
.ShowInput = True
.ShowError = True
End With
'if a file name is passed in, save the workbook and turn on highlight
changes
If Len(FileName) > 1 Then
With objWorkbk
objWorkbk.SaveAs FileName, , , , , , xlshared
.HighlightChangesOptions xlAllChanges
.ListChangesOnNewSheet = False
.HighlightChangesOnScreen = True
End With
End If
If ShowFile = True Then
objXL.Visible = True
Else
objWorkbk.Close
End If
ExitHere:
Set objWorkSht = Nothing
Set objWorkbk = Nothing
Set objXL = Nothing
Set rst = Nothing
Exit Sub
ErrHandler:
Dim strErrString As String
Select Case Err.Number
Case Else
strErrString = "Unexpected Error: " & Err.Number & vbCrLf
strErrString = strErrString & Err.Description
MsgBox strErrString, vbCritical + vbOKOnly, "Sub:
subGenerateExcel of mdlExcel"
End Select
Resume ExitHere
End Sub
