Exporting to an Excell template 1

[jedel]

Hi all,

Been working on some code that I found on this Forum and I'm have a few problems with it. I want to export multiple records to specific columns in an excel spreadsheet.

The code I have so far:

Public Sub ExportQuery()
On Error GoTo err_Handler

    'Excel object variables
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    
    Dim sTemplate As String
    Dim sTempFile As String
    Dim sOutput As String
    Dim counter
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim sSQL As String
    Dim IRecords As Long
    Dim iRow As Integer
    Dim iCol As Integer
    Dim iFld As Integer
     
   sOutput = CurrentProject.Path & "\RosterTemplate.xls"
    
    'Create the Excel Application, Workbook and Worksheet and Database object
    Set appExcel = New Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Open(sOutput)
    
    sSQL = "SELECT * FROM tblSample"
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
    If Not rst.BOF Then
    rst.MoveFirst
counter = 1
    Do While Not rst.EOF
        With wbk
            .Sheets("Week1,2").Cells(counter, "B1") = rst.Fields("AppointmentDate")
            .Sheets("Week1,2").Cells(counter, "B2") = rst.Fields("AppointmentDesc")
            .Sheets("Week1,2").Cells(counter, "B4") = rst.Fields("AppointmentTime")
            .Sheets("Week1,2").Cells(counter, "B5") = rst.Fields("MC")
            .Sheets("Week1,2").Cells(counter, "B6") = rst.Fields("Who")
            .Sheets("Week1,2").Cells(counter, "B7") = rst.Fields("LeadVox")
            .Sheets("Week1,2").Cells(counter, "B8") = rst.Fields("Vox1")
            .Sheets("Week1,2").Cells(counter, "B9") = rst.Fields("vox2")
            .Sheets("Week1,2").Cells(counter, "B10") = rst.Fields("vox3")
            .Sheets("Week1,2").Cells(counter, "B11") = rst.Fields("vox4")
            .Sheets("Week1,2").Cells(counter, "B12") = rst.Fields("vox5")
            .Sheets("Week1,2").Cells(counter, "B13") = rst.Fields("vox6")
            .Sheets("Week1,2").Cells(counter, "B14") = rst.Fields("piano")
            .Sheets("Week1,2").Cells(counter, "B15") = rst.Fields("keys1")
            .Sheets("Week1,2").Cells(counter, "B16") = rst.Fields("keys2")
            .Sheets("Week1,2").Cells(counter, "B17") = rst.Fields("LGtr")
            .Sheets("Week1,2").Cells(counter, "B18") = rst.Fields("RGtr")
            .Sheets("Week1,2").Cells(counter, "B19") = rst.Fields("AccGtr")
            .Sheets("Week1,2").Cells(counter, "B20") = rst.Fields("Bass")
            .Sheets("Week1,2").Cells(counter, "B21") = rst.Fields("sax")
            .Sheets("Week1,2").Cells(counter, "B22") = rst.Fields("Drums")
            .Sheets("Week1,2").Cells(counter, "B23") = rst.Fields("FOH")
            .Sheets("Week1,2").Cells(counter, "B24") = rst.Fields("SndStg")
            .Sheets("Week1,2").Cells(counter, "B25") = rst.Fields("Light")
            .Sheets("Week1,2").Cells(counter, "B26") = rst.Fields("LightAss")
            .Sheets("Week1,2").Cells(counter, "B27") = rst.Fields("Graphic")
            .Sheets("Week1,2").Cells(counter, "B28") = rst.Fields("vision")
            .Sheets("Week1,2").Cells(counter, "B29") = rst.Fields("cam1")
            .Sheets("Week1,2").Cells(counter, "B30") = rst.Fields("cam2")
            .Sheets("Week1,2").Cells(counter, "B31") = rst.Fields("rec")
            .Sheets("Week1,2").Cells(counter, "B32") = rst.Fields("Items")
            .Sheets("Week1,2").Cells(counter, "B33") = rst.Fields("Songlist")

' repeat these statements for each field
            counter = counter + 1

        End With
        rst.MoveNext
    Loop
    rst.Close
    
   
exit_Here:
'Cleanup all objects (resume next on errors)
Set wbk = Nothing
appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
Exit Sub

err_Handler:
    MsgBox "Error is " & Err.Description
    Resume exit_Here
 End If
End Sub

The original Sub heading was

Public Sub ExportQuery() as String

But this shows up as red in Access 2003

I referenced Excel object library 11.0 to eliminate the application errors.

When I apply the code. It will open the spreadsheet, but it will not go any further and comes up with and error:
"Application-defined or Object-defined Error"

Any help would be appreciated

Cheers

Dean

-------------------------------------------------------------
"The most overlooked advantage of owning a computer is that if they foul up there's no law against whacking them around a bit."

 

[ck1999]

try

sSQL = "SELECT * FROM tblSample" _
& " WHERE dteMonth='" & Forms!DteSelectFRM!cboMonth _
& "' ORDER BY AppointmentDate, AppointmentTime

 

[jedel]

ck1999 gets the prize!

PHV, Thanks heaps for your efforts. I'm still interested in your earlier method about CopyFromRecordset method. I can't find anything in any helpfiles about it. Do you think you could point be in the right direction?

ck1999.

Well done! I would never have picked that.

Cheers

Dean

-------------------------------------------------------------
"The most overlooked advantage of owning a computer is that if they foul up there's no law against whacking them around a bit."

 

[PHV]

Look in the Excel VBA help file.
Or here:

http://msdn2.microsoft.com/en-us/library/aa223845(office.11).aspx

However, when I suggested that method I didn't know you worked on a column basis instead of row.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[billcute]

ck1999,
For the sake of future reader, would please post the corrected code here?

Regards
Bill

 

[billcute]

While the objective of this thread is to make assess to the tutorial posible to others .... just as "jedel" benefited by using code that he got from here.

Since there were answers back and forth between asker and the expert, it would be important to post the revised code on this thread as suggested by ck1999.

 

[jedel]

billcute,

I wouldn't be getting too aggrivatd with ck1999. after all it was my code that he was helping me with.

Below is the code that I ended up with, by the help of ck1999 and PHV. It uses an array setup and exports records vertically down one column and then moves to the next column in the array and repeats the process. I have this happen twice for the utility that I have been designing. You will need to change database, field and file names to suite what you want.

Enjoy.

Private Sub Command16_Click()
On Error GoTo Err_Upload_Click

Dim db As Database
Dim rs As Recordset
'Dim ftp, uname, pword, fle, sfle, sdir, mode As String

'ftp = DLookup("domain", "FTPTbl")
'uname = DLookup("Username", "FTPTbl")
'fle = DLookup("FileName", "FTPTbl")
'sfle = DLookup("sFilename", "FTPTbl")
'sdir = DLookup("Directory", "FTPTbl")
'mode = DLookup("tfrmode", "FTPTbl")

Set db = CurrentDb
Set rs = db.OpenRecordset("FTPTbl", dbOpenDynaset)

With rs
.MoveLast
.MoveFirst

While Not .EOF
' Check for Selected file
If Nz(!FileName, "") = "" Then
    MsgBox "Please select file to upload first!"
    Exit Sub
End If

' Check for FTP Server
If Nz(!domain, "") = "" Then
    MsgBox "Please enter FTP Domain!"
    Exit Sub
End If

' Check for UserName
If Nz(!UserName, "") = "" Then
    MsgBox "Please enter User Name!"
    Exit Sub
End If

' Check for Password
If Nz(!pword, "") = "" Then
    MsgBox "Please enter Password!"
    Exit Sub
End If

' Set Default upload directory to root if nothing supplied
If Nz(!Directory, "") = "" Then
    Me!ServerDir = "/"
    Me.Refresh
End If

Me.lblLink.Visible = True
Me.lblLink.Caption = "Uploading Database, please wait..."
Me.Repaint

DoCmd.Hourglass True
' Upload file
If FTPFile(!domain, !UserName, !pword, !FileName, !sFilename, !Directory, !tfrmode) Then
'MsgBox "Upload - Complete!"
End If
.MoveNext
Wend
If .EOF Then
MsgBox "Upload - Complete!"
Me.lblLink.Visible = False
End If
End With
DoCmd.Hourglass False

Exit_Upload_Click:
    Exit Sub

Err_Upload_Click:
    MsgBox "Error in Upload_Click : " & Err.Description
    Resume Exit_Upload_Click
End Sub

-------------------------------------------------------------
"The most overlooked advantage of owning a computer is that if they foul up there's no law against whacking them around a bit."

 

[jedel]

OOPS! WRONG CODE. TRhe one above was to upload the files using the FTP code found in the FAQ. Below is the code your were after, Humblest apologies!!!

Private Sub cbomonth_AfterUpdate()
On Error GoTo err_Handler

    'Excel object variables
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    
    Dim sTemplate As String
    Dim sTempFile As String
    Dim sOutput As String
    Dim Counter
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim db As Database
    Dim rs As Recordset
    Dim sSQL As String
    Dim IRecords As Long
    Dim iRow As Integer
    Dim iCol As Integer
    Dim iFld As Integer
    Dim mth As String
    Dim path As String
    

path = Application.CurrentProject.path
'MsgBox path

    mth = Me.cboMonth
    'MsgBox "month is: " & mth, vbOKOnly
    
    vcol = Array("b", "c", "d", "e", "f", "g", "i", "j", "k", "l")
    
   sOutput = CurrentProject.path & "\RosterTemplate.xlt"
    
    'Create the Excel Application, Workbook and Worksheet and Database object
    Set appExcel = New Excel.Application
    appExcel.Visible = True
    Set wbk = appExcel.Workbooks.Open(sOutput)
    
    sSQL = "SELECT * FROM tblSample" _
    & " WHERE dteMonth='" & Forms!DteSelectFRM!cboMonth _
    & "' ORDER BY AppointmentDate, AppointmentTime"
    

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(sSQL, dbOpenDynaset)
    
    If Not rst.BOF Then
    rst.MoveFirst
    
Counter = 0
    Do While Not rst.EOF
        With wbk
            .Sheets("Week1,2").Cells("1", vcol(Counter)) = rst.Fields("AppointmentDate")
            .Sheets("Week1,2").Cells("2", vcol(Counter)) = rst.Fields("AppointmentDesc")
            .Sheets("Week1,2").Cells("4", vcol(Counter)) = rst.Fields("AppointmentTime")
            .Sheets("Week1,2").Cells("5", vcol(Counter)) = rst.Fields("MC")
            .Sheets("Week1,2").Cells("6", vcol(Counter)) = rst.Fields("Who")
            .Sheets("Week1,2").Cells("7", vcol(Counter)) = rst.Fields("LeadVox")
            .Sheets("Week1,2").Cells("8", vcol(Counter)) = rst.Fields("Vox1")
            .Sheets("Week1,2").Cells("9", vcol(Counter)) = rst.Fields("vox2")
            .Sheets("Week1,2").Cells("10", vcol(Counter)) = rst.Fields("vox3")
            .Sheets("Week1,2").Cells("11", vcol(Counter)) = rst.Fields("vox4")
            .Sheets("Week1,2").Cells("12", vcol(Counter)) = rst.Fields("vox5")
            .Sheets("Week1,2").Cells("13", vcol(Counter)) = rst.Fields("vox6")
            .Sheets("Week1,2").Cells("14", vcol(Counter)) = rst.Fields("piano")
            .Sheets("Week1,2").Cells("15", vcol(Counter)) = rst.Fields("keys1")
            .Sheets("Week1,2").Cells("16", vcol(Counter)) = rst.Fields("keys2")
            .Sheets("Week1,2").Cells("17", vcol(Counter)) = rst.Fields("LGtr")
            .Sheets("Week1,2").Cells("18", vcol(Counter)) = rst.Fields("RGtr")
            .Sheets("Week1,2").Cells("19", vcol(Counter)) = rst.Fields("AccGtr")
            .Sheets("Week1,2").Cells("20", vcol(Counter)) = rst.Fields("Bass")
            .Sheets("Week1,2").Cells("21", vcol(Counter)) = rst.Fields("sax")
            .Sheets("Week1,2").Cells("22", vcol(Counter)) = rst.Fields("Drums")
            .Sheets("Week1,2").Cells("23", vcol(Counter)) = rst.Fields("FOH")
            .Sheets("Week1,2").Cells("24", vcol(Counter)) = rst.Fields("SndStg")
            .Sheets("Week1,2").Cells("25", vcol(Counter)) = rst.Fields("Light")
            .Sheets("Week1,2").Cells("26", vcol(Counter)) = rst.Fields("LightAss")
            .Sheets("Week1,2").Cells("27", vcol(Counter)) = rst.Fields("Graphic")
            .Sheets("Week1,2").Cells("28", vcol(Counter)) = rst.Fields("vision")
            .Sheets("Week1,2").Cells("29", vcol(Counter)) = rst.Fields("cam1")
            .Sheets("Week1,2").Cells("30", vcol(Counter)) = rst.Fields("cam2")
            .Sheets("Week1,2").Cells("31", vcol(Counter)) = rst.Fields("rec")
            .Sheets("Week1,2").Cells("32", vcol(Counter)) = rst.Fields("Items")
            .Sheets("Week1,2").Cells("33", vcol(Counter)) = rst.Fields("Songlist")
    
' repeat these statements for each field
            Counter = Counter + 1

        End With
        rst.MoveNext
    Loop
End If
vcol2 = Array("M", "N", "O", "P", "Q")

sSQL = "SELECT * FROM tblSample" _
& " WHERE dteMonth='" & Forms!DteSelectFRM!cboMonth _
& "' And (Not (tblSample.Cdir) = 'isnull')" _
& " ORDER BY tblSample.AppointmentDate;"

Set rst = dbs.OpenRecordset(sSQL, dbOpenDynaset)

If Not rst.BOF Then
rst.MoveFirst
    
Counter = 0
    Do While Not rst.EOF
        With wbk
            .Sheets("Week1,2").Cells("1", vcol2(Counter)) = rst.Fields("AppointmentDate")
            .Sheets("Week1,2").Cells("5", vcol2(Counter)) = rst.Fields("Cdir")
            .Sheets("Week1,2").Cells("7", vcol2(Counter)) = rst.Fields("c1")
            .Sheets("Week1,2").Cells("8", vcol2(Counter)) = rst.Fields("c2")
            .Sheets("Week1,2").Cells("9", vcol2(Counter)) = rst.Fields("c3")
            .Sheets("Week1,2").Cells("10", vcol2(Counter)) = rst.Fields("c4")
            .Sheets("Week1,2").Cells("11", vcol2(Counter)) = rst.Fields("c5")
            .Sheets("Week1,2").Cells("12", vcol2(Counter)) = rst.Fields("c6")
            .Sheets("Week1,2").Cells("13", vcol2(Counter)) = rst.Fields("c7")
            .Sheets("Week1,2").Cells("14", vcol2(Counter)) = rst.Fields("c8")
            .Sheets("Week1,2").Cells("15", vcol2(Counter)) = rst.Fields("c9")
            .Sheets("Week1,2").Cells("16", vcol2(Counter)) = rst.Fields("c10")
            .Sheets("Week1,2").Cells("17", vcol2(Counter)) = rst.Fields("c11")
            .Sheets("Week1,2").Cells("18", vcol2(Counter)) = rst.Fields("c12")
            .Sheets("Week1,2").Cells("19", vcol2(Counter)) = rst.Fields("c13")
            .Sheets("Week1,2").Cells("20", vcol2(Counter)) = rst.Fields("c14")
            .Sheets("Week1,2").Cells("21", vcol2(Counter)) = rst.Fields("c15")
            .Sheets("Week1,2").Cells("22", vcol2(Counter)) = rst.Fields("c16")
            .Sheets("Week1,2").Cells("23", vcol2(Counter)) = rst.Fields("c17")
            .Sheets("Week1,2").Cells("24", vcol2(Counter)) = rst.Fields("c18")
            .Sheets("Week1,2").Cells("25", vcol2(Counter)) = rst.Fields("c19")
            .Sheets("Week1,2").Cells("26", vcol2(Counter)) = rst.Fields("c20")
    
' repeat these statements for each field
            Counter = Counter + 1
    
    End With
        rst.MoveNext
    Loop
End If

wbk.SaveAs FileName:=path & "\" & Me.cboMonth & "Roster" & Format(Date, "yyyy")

Set db = CurrentDb
Set rs = db.OpenRecordset("FTPTbl", dbOpenDynaset)

With rs
.MoveLast
.Edit
!FileName = path & "\" & Me.cboMonth & "Roster" & Format(Date, "yyyy") & ".xls"
!sFilename = Me.cboMonth & "Roster" & Format(Date, "yyyy") & ".xls"
.Update
End With

Set rs = db.OpenRecordset("DLRosterTBL", dbOpenDynaset)



If IsNull(DLookup("dteMonth", "DLRosterTBL", "dteMonth = '" & Me.cboMonth & "'")) Then

With rs

.AddNew
!dteMonth = Me.cboMonth
!FileName = Me.cboMonth & "Roster" & Format(Date, "yyyy") & ".xls"
.Update
End With

Set db = Nothing
Set rs = Nothing
Else
End If

rst.Close
   
exit_Here:
'Cleanup all objects (resume next on errors)
Set wbk = Nothing


appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
Exit Sub

err_Handler:
    MsgBox "Error is " & Err.Description
    Resume exit_Here



End Sub

-------------------------------------------------------------
"The most overlooked advantage of owning a computer is that if they foul up there's no law against whacking them around a bit."

 

[billcute]

jedel:
Thanks for your quick response. That was very kind of you.
I read with interest and was just wondering why you opted to output one column at a time?

Secondly,
If you could upload a very small sample db of about 10 records (of no value) here - it will be great to test your method. If not, I can understand.