I have an export that I'm trying to perform from an access query. I got it working until the part where it was resaving the excel file. Since then I've been trying to reference examples that I have looked at (in addition to one I've done). I noticed there are a couple different ways to do this and the syntax is way different. I don't understand enough about the process to know which is appropriate for me to be using. I've fiddled with it and now I can't even get it to do anything when I click the cmdCreateform button. I'm either mixing and matching syntax when I shouldn't be or have deleted something critical I shouldn't have and have been over this so much I just don't see it. Anything obvious you can see? Here's what I have...
Option Compare Database
Option Explicit
Sub cmdCreateform_Click()
Dim WB As Workbook
Dim xlApp As New Excel.Application
Dim DB As Database
Dim WS As Excel.Worksheet
Dim RSPtarep As Recordset
Dim RSStudents As Recordset
Dim strFileName As String
Dim strFolder As String
Dim strTeacher As String
Dim strGrade As String
Dim introw As Long
Dim Intcol As Long
strFolder = Trim(txtfolder)
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
Set DB = CurrentDb
Set RSPtarep = DB.OpenRecordset("PTA Reps", dbOpenSnapshot)
Set RSStudents = DB.OpenRecordset("Excel Sort",dbOpenSnapshot)
RSStudents.MoveFirst
Do Until RSStudents.EOF
Intcol = 0
introw = 0
strGrade = RSStudents("Grade")
strFileName = strFolder & strGrade & ".xlsx"
txtCurrProfile = "Creating " & strGrade & ".xlsx..."
DoEvents
With xlApp
.Visible = False
Set WB = .Workbooks.CreateObject(strFileName)
'.Workbooks(1).SaveAs (strFileName)
End With
Do While strGrade = RSStudents("Grade")
strTeacher = RSStudents("Teacher")
introw = introw + 1
Intcol = Intcol + 1
xlApp.Worksheets(1).Cells(introw, Intcol) = RSStudents("Teacher")
introw = introw + 2
xlApp.Worksheets(1).Cells(introw, Intcol) = RSStudents("Extension")
introw = introw + 3
Do While strTeacher = RSStudents("Teacher")
xlApp.Worksheets(1).Cells(introw, Intcol) = RSStudents("First") & " " & RSStudents("Last")
introw = introw + 1
RSStudents.MoveNext
If RSStudents.EOF Then Exit Do
Loop
introw = 0
If RSStudents.EOF Then Exit Do
Loop
With xlApp
.Workbooks(1).SaveAs (strFileName)
.Workbooks(1).Close
End With
Loop
xlApp.Quit
RSStudents.Close
DB.Close
Set xlApp = Nothing
Set RSStudents = Nothing
Set DB = Nothing
txtCurrProfile = "Done!"
DoEvents
End Sub
Option Compare Database
Option Explicit
Sub cmdCreateform_Click()
Dim WB As Workbook
Dim xlApp As New Excel.Application
Dim DB As Database
Dim WS As Excel.Worksheet
Dim RSPtarep As Recordset
Dim RSStudents As Recordset
Dim strFileName As String
Dim strFolder As String
Dim strTeacher As String
Dim strGrade As String
Dim introw As Long
Dim Intcol As Long
strFolder = Trim(txtfolder)
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
Set DB = CurrentDb
Set RSPtarep = DB.OpenRecordset("PTA Reps", dbOpenSnapshot)
Set RSStudents = DB.OpenRecordset("Excel Sort",dbOpenSnapshot)
RSStudents.MoveFirst
Do Until RSStudents.EOF
Intcol = 0
introw = 0
strGrade = RSStudents("Grade")
strFileName = strFolder & strGrade & ".xlsx"
txtCurrProfile = "Creating " & strGrade & ".xlsx..."
DoEvents
With xlApp
.Visible = False
Set WB = .Workbooks.CreateObject(strFileName)
'.Workbooks(1).SaveAs (strFileName)
End With
Do While strGrade = RSStudents("Grade")
strTeacher = RSStudents("Teacher")
introw = introw + 1
Intcol = Intcol + 1
xlApp.Worksheets(1).Cells(introw, Intcol) = RSStudents("Teacher")
introw = introw + 2
xlApp.Worksheets(1).Cells(introw, Intcol) = RSStudents("Extension")
introw = introw + 3
Do While strTeacher = RSStudents("Teacher")
xlApp.Worksheets(1).Cells(introw, Intcol) = RSStudents("First") & " " & RSStudents("Last")
introw = introw + 1
RSStudents.MoveNext
If RSStudents.EOF Then Exit Do
Loop
introw = 0
If RSStudents.EOF Then Exit Do
Loop
With xlApp
.Workbooks(1).SaveAs (strFileName)
.Workbooks(1).Close
End With
Loop
xlApp.Quit
RSStudents.Close
DB.Close
Set xlApp = Nothing
Set RSStudents = Nothing
Set DB = Nothing
txtCurrProfile = "Done!"
DoEvents
End Sub
