Hi, I need to loop through a recordset in Access to create an Excel report that has a new sheet for each record in the recordset. Any help is appreciated. I created similar code that creates a new workbook for each record, and I assume this code will be similar -
Private Sub cmdExport_Click()
Dim db As DAO.Database
Dim rsEmployees As DAO.Recordset
Dim strTitle As String
Dim strQry As String
Dim qdfTemp As DAO.QueryDef
Dim strQdf As String
If cboName.Value <> "" Then
MsgBox "Leave the criteria blank.", vbOKOnly
cboName.Value = ""
DoCmd.ShowAllRecords
Exit Sub
End If
If cboName.Value = "" Then
Set db = CurrentDb()
Set rsEmployees = db.OpenRecordset("select distinct * from tblEmployees")
strQdf = "Employees"
Do While Not rsEmployees.EOF
strTitle = rsEmployees.Fields(1).Value
strQry = "select * from tblEmployees where Name = '" & strTitle & "'"
Set qdfTemp = CurrentDb.CreateQueryDef(strQdf, strQry)
qdfTemp.Close
Set qdfTemp = Nothing
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, strQdf, "C:\Users\mdubi\OneDrive\Desktop\" & strTitle & ".xls"
CurrentDb.QueryDefs.Delete strQdf
rsEmployees.MoveNext
Loop
rsEmployees.Close
End If
MsgBox "Files Exported.", vbOKOnly
End Sub
Private Sub cmdExport_Click()
Dim db As DAO.Database
Dim rsEmployees As DAO.Recordset
Dim strTitle As String
Dim strQry As String
Dim qdfTemp As DAO.QueryDef
Dim strQdf As String
If cboName.Value <> "" Then
MsgBox "Leave the criteria blank.", vbOKOnly
cboName.Value = ""
DoCmd.ShowAllRecords
Exit Sub
End If
If cboName.Value = "" Then
Set db = CurrentDb()
Set rsEmployees = db.OpenRecordset("select distinct * from tblEmployees")
strQdf = "Employees"
Do While Not rsEmployees.EOF
strTitle = rsEmployees.Fields(1).Value
strQry = "select * from tblEmployees where Name = '" & strTitle & "'"
Set qdfTemp = CurrentDb.CreateQueryDef(strQdf, strQry)
qdfTemp.Close
Set qdfTemp = Nothing
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, strQdf, "C:\Users\mdubi\OneDrive\Desktop\" & strTitle & ".xls"
CurrentDb.QueryDefs.Delete strQdf
rsEmployees.MoveNext
Loop
rsEmployees.Close
End If
MsgBox "Files Exported.", vbOKOnly
End Sub