Export from a query

[Delindan]

I am new at programming so bear with the basic questions. I am trying to write code that will export data from a query for individual specialists. The query contains multiple breeder records for each specialist. So in other words, create a file for first specialist, fill in breeder records, then move to create a file for the next specialist and fill in the breeder files until it reaches the end of the file.

I had some code given to me to get me started and it is getting stuck. It creates the first breeder file and fills in the first specialist name continuously...I have to break out of it. Obviously I'm missing something...can someone help find what I'm missing? I'll fill in the code.

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 blnSheetDone As Boolean

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 Until RSSpecialist.EOF
blnSheetDone = Profile_Sheet(RSSpecialist("FS Specialist"), strFolder, strSpcTemplate, xlApp)
RSSpecialist.MoveNext
Loop

txtCurrProfile = "Done!"
DoEvents
xlApp.Quit
RSSpecialist.Close
DB.Close

Set xlApp = Nothing
Set RSSpecialist = Nothing
Set DB = Nothing

End Sub

Private Function Profile_Sheet(strSpecialistName As String, strFolder As String, strSpcTemplate As String, xlApp As Excel.Application) As Boolean

Dim WB As Workbook
Dim DB As Database
Dim RSSpecialist As Recordset
Dim strFileName As String
Dim strSheetName As String
Dim introw As Long

Profile_Sheet = False

Set DB = CurrentDb

Set RSSpecialist = DB.OpenRecordset("FS Data", dbOpenSnapshot)

RSSpecialist.FindFirst "[FS Specialist]='" & strSpecialistName & "'"
If Not RSSpecialist.NoMatch Then
strFileName = strFolder & "FS Specialist " & strSpecialistName & ".xlsx"
txtCurrProfile = "Exporting " & strSpecialistName & " ..."
DoEvents

With xlApp
.Visible = False
Set WB = .Workbooks.Open(strSpcTemplate)
WB.SaveAs (strFileName)
End With

xlApp.Worksheets(1).Cells(1, 2) = RSSpecialist("FS Specialist")
introw = 3
xlApp.Worksheets(1).Cells(introw, 1) = RSSpecialist("Breeder")
Do While Not RSSpecialist.NoMatch
introw = introw + 1
xlApp.Worksheets(1).Cells(introw, 1) = RSSpecialist("Breeder")
Loop

With xlApp
.Workbooks(1).SaveAs (strFileName)
End With
End If

RSSpecialist.Close
DB.Close

Set RSSpecialist = Nothing
Set DB = Nothing

With xlApp
.Workbooks(1).Save
.Workbooks(1).Close
End With

Profile_Sheet = True

End Function