Export to Excel with unknown multiple worksheets

[syoung4]

I am trying to send the results of a query that has been sorted by ContractName to Excel and put each set of Contract data on to a separate worksheet.

The problem I have is there are 22 possible contracts and when the query is run the data returned may only have 2 contracts worth of data.

I have created a table with all the 22 contracts and make this the criteria for looping through the results of the query. Please could anyone help me with this.

I would also like all the data and code to be ready before the export so that I can just have a save api pop up to save the sheet.

Here is my code so far it will only export to one sheet.
I will not know how many sheets to define as I will not know how many contracts have been returned.

I need to be abe to have it export to how ever many contracts that have been returned.

Private Sub btnMyArray_Click()
Dim db As DAO.Database, rsPaymentCert As Recordset, Criteria As Variant
Dim rsCriteria As Recordset
Dim rs As Recordset
Dim rs1 As Recordset
Dim strsql As String
Dim qdf As QueryDef
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim objXL As Excel.Application
Dim objWkb As Workbook
Dim objSht As Worksheet
Dim meterReturn As Integer
Dim exSheet As Excel.Worksheet
Dim exSheet2 As Excel.Worksheet
Dim exSheet3 As Excel.Worksheet
Dim exSheet4 As Excel.Worksheet
Dim exSheet5 As Excel.Worksheet
Dim exSheet6 As Excel.Worksheet
Dim exSheet7 As Excel.Worksheet
Dim exSheet8 As Excel.Worksheet
Dim exSheet9 As Excel.Worksheet
Dim exSheet10 As Excel.Worksheet
Dim i As Integer
Dim NoOfCols As Integer
Dim NoOfRows As Integer
'Start Progress Meter at bottom left of screen
meterReturn = SysCmd(acSysCmdInitMeter, "Generating Excel Please wait process takes about 1 min...", 100)
Set db = CurrentDb
Set rsCriteria = db.OpenRecordset("tblContracts")
Set rs = db.OpenRecordset("PaymentCertificatetmp", DB_OPEN_DYNASET)
Criteria = "ContractName=" & rsCriteria("Contract")

rsCriteria.MoveFirst
strsql = "SELECT * FROM PaymentCertificatetmp where "
strsql = strsql & "[ContractName]= '" & rsCriteria![Contract] & "'"
'*** loop to move through the records in Criteria table
Do Until rsCriteria.EOF

rsCriteria.MoveNext
'*** loop to move through the records in Criteria table
'Do Until rsCriteria.EOF
'*** create the Select query based on
' the first record in the Criteria table
'strsql = "SELECT * FROM [PaymentCertificatetmp] WHERE "
' strsql = strsql & "[ContractName]= '" & rsCriteria!["ContractNo"] & "'"
'***************************************
'This section outputs to Excel

'Excel objects to manipulate Excel
Dim exApp As Excel.Application
Dim exBook As Excel.Workbook
'Dim exSheet As Excel.Worksheet

'Instantiate the excel objects
Set exApp = New Excel.Application

Set exBook = exApp.Workbooks.add

exApp.Visible = True

exApp.Interactive = False

Set exSheet = exBook.Worksheets(1)

If Not rs.EOF Then rs.MoveLast: rs.MoveFirst

'Populate the variables
NoOfCols = rs.Fields.Count
NoOfRows = rs.RecordCount

'Pop the data into Excel
exSheet.Range("A2").CopyFromRecordset rs

'Write in the column headings
For i = 0 To NoOfCols - 1

exSheet.Cells(1, i + 1).Value = rs.Fields(i).Name

Next i

'Use our variables to format the data populated cells ONLY
exSheet.Cells.Range("A1", ExcelCodes(NoOfCols) & 1).Interior.Color = vbYellow

'And again - using both this time
exSheet.Cells.Range("A1", ExcelCodes(NoOfCols) & (NoOfRows + 1)).Borders.Color = RGB(0, 0, 0)

'Adjust column widths
exSheet.Columns.EntireColumn.AutoFit

'Save it
' exBook.SaveAs "C:\Temp\Temp.xls"

ExportData_Exit:

'Very important - always account for in error trap
exApp.Interactive = True

'Clean Up
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing

Set exSheet = Nothing
Set exBook = Nothing
Set exApp = Nothing

Exit Sub
'***************************************

rsCriteria.Close
Loop

'Kill sFile
' objWkb.SaveAs ("S:\Invoicing\Part Payment Checker\Plan Do\SidandSarahsPlanDo.xls")
'objWkb.Application.Quit

'Turn the Progress meter off
meterReturn = SysCmd(acSysCmdRemoveMeter)





End Sub

Function ExcelCodes(ByVal intColNo As Integer) As String

Dim strCol As String

Do While intColNo > -1
If intColNo > 26 Then
strCol = Chr(64 + ((intColNo - 1) \ 26))
intColNo = intColNo - (26 * ((intColNo - 1) \ 26))
Else
strCol = strCol & Chr(64 + intColNo)
Exit Do
End If
Loop

ExcelCodes = strCol


End Function

Thank you.

regards,
Sid.