I am exporting a query from access into individual excel files for each specialist. I'm so close and have been struggling over this last bit. When the routine reaches the last specialist it creates that last file just fine however doesn't save or close it. When I run debug it points to the line Do While RSSpecialist("FS Specialist") = strSpecialistName. So I think it gets to the end of the file and doesn't know what to do. The thing that confuses me is that all the previous files save and close...it's only the last one that hangs up. I'll post the code...any ideas would be appreciated!
Option Compare Database
Option Explicit
Private Sub cmdCreateTemplates_Click()
Dim DB As Database
Dim xlApp As New Excel.Application
Dim RSSpecialist As Recordset
Dim strSpcTemplate As String
Dim strFolder As String
Dim WB As Workbook
Dim strFileName As String
Dim strSheetName As String
Dim introw As Long
Dim strSpecialistName As String
strFolder = Trim(txtFolder)
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
strSpcTemplate = strFolder & "Specialist Entries Table.xlsx"
txtCurrProfile = Null
DoEvents
Set DB = CurrentDb
Set RSSpecialist = DB.OpenRecordset("FS Data", dbOpenSnapshot)
RSSpecialist.MoveFirst
Do While Not RSSpecialist.EOF
strSpecialistName = RSSpecialist("FS Specialist")
strFileName = strFolder & "FS Specialist " & strSpecialistName & ".xlsx"
txtCurrProfile = "Exporting " & strSpecialistName & " ..."
DoEvents
With xlApp
.Visible = False
Set WB = .Workbooks.Open(strSpcTemplate)
.Workbooks(1).SaveAs (strFileName)
End With
xlApp.Worksheets(1).Cells(1, 2) = RSSpecialist("FS Specialist")
introw = 3
Do While RSSpecialist("FS Specialist") = strSpecialistName
xlApp.Worksheets(1).Cells(introw, 1) = RSSpecialist("Breeder")
xlApp.Worksheets(1).Cells(introw, 2) = RSSpecialist("Family")
xlApp.Worksheets(1).Cells(introw, 3) = RSSpecialist("Crop")
xlApp.Worksheets(1).Cells(introw, 4) = RSSpecialist("Sub Crop")
xlApp.Worksheets(1).Cells(introw, 5) = RSSpecialist("Data Year")
xlApp.Worksheets(1).Cells(introw, 6) = RSSpecialist("advcd phs 4")
xlApp.Worksheets(1).Cells(introw, 7) = RSSpecialist("advcd phs 5 advcd comm")
xlApp.Worksheets(1).Cells(introw, 8) = RSSpecialist("advcd phs 5 entered FS at phase 3")
xlApp.Worksheets(1).Cells(introw, 9) = RSSpecialist("advcd phs 5 entered FS at phase 4")
xlApp.Worksheets(1).Cells(introw, 10) = RSSpecialist("moved phs 4 to phs 6")
xlApp.Worksheets(1).Cells(introw, 10) = RSSpecialist("Estimate of new entries")
introw = introw + 1
RSSpecialist.MoveNext
Loop
With xlApp
.Workbooks(1).Save
.Workbooks(1).Close
End With
Loop
xlApp.Quit
RSSpecialist.Close
DB.Close
Set xlApp = Nothing
Set RSSpecialist = Nothing
Set DB = Nothing
txtCurrProfile = "Done!"
DoEvents
End Sub
Option Compare Database
Option Explicit
Private Sub cmdCreateTemplates_Click()
Dim DB As Database
Dim xlApp As New Excel.Application
Dim RSSpecialist As Recordset
Dim strSpcTemplate As String
Dim strFolder As String
Dim WB As Workbook
Dim strFileName As String
Dim strSheetName As String
Dim introw As Long
Dim strSpecialistName As String
strFolder = Trim(txtFolder)
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
strSpcTemplate = strFolder & "Specialist Entries Table.xlsx"
txtCurrProfile = Null
DoEvents
Set DB = CurrentDb
Set RSSpecialist = DB.OpenRecordset("FS Data", dbOpenSnapshot)
RSSpecialist.MoveFirst
Do While Not RSSpecialist.EOF
strSpecialistName = RSSpecialist("FS Specialist")
strFileName = strFolder & "FS Specialist " & strSpecialistName & ".xlsx"
txtCurrProfile = "Exporting " & strSpecialistName & " ..."
DoEvents
With xlApp
.Visible = False
Set WB = .Workbooks.Open(strSpcTemplate)
.Workbooks(1).SaveAs (strFileName)
End With
xlApp.Worksheets(1).Cells(1, 2) = RSSpecialist("FS Specialist")
introw = 3
Do While RSSpecialist("FS Specialist") = strSpecialistName
xlApp.Worksheets(1).Cells(introw, 1) = RSSpecialist("Breeder")
xlApp.Worksheets(1).Cells(introw, 2) = RSSpecialist("Family")
xlApp.Worksheets(1).Cells(introw, 3) = RSSpecialist("Crop")
xlApp.Worksheets(1).Cells(introw, 4) = RSSpecialist("Sub Crop")
xlApp.Worksheets(1).Cells(introw, 5) = RSSpecialist("Data Year")
xlApp.Worksheets(1).Cells(introw, 6) = RSSpecialist("advcd phs 4")
xlApp.Worksheets(1).Cells(introw, 7) = RSSpecialist("advcd phs 5 advcd comm")
xlApp.Worksheets(1).Cells(introw, 8) = RSSpecialist("advcd phs 5 entered FS at phase 3")
xlApp.Worksheets(1).Cells(introw, 9) = RSSpecialist("advcd phs 5 entered FS at phase 4")
xlApp.Worksheets(1).Cells(introw, 10) = RSSpecialist("moved phs 4 to phs 6")
xlApp.Worksheets(1).Cells(introw, 10) = RSSpecialist("Estimate of new entries")
introw = introw + 1
RSSpecialist.MoveNext
Loop
With xlApp
.Workbooks(1).Save
.Workbooks(1).Close
End With
Loop
xlApp.Quit
RSSpecialist.Close
DB.Close
Set xlApp = Nothing
Set RSSpecialist = Nothing
Set DB = Nothing
txtCurrProfile = "Done!"
DoEvents
End Sub