Find duplicate field values and export those records to excel file

I need help with the code for functionality that loops through a recordset and finds all records that have the same value in one of the fields and then takes those records and saves them to an excel template. After it does that, I need it to go to the next unique value and save the group of records matching that value to its own excel file.

I have the code for the export to excel and saving unique files but not for looping and grouping. As you can see, the whole sub is to save unique spreadsheets and them attach them to an email.

Public Sub ExpirationSub()

DoCmd.SetWarnings (WarningsOff)
DoCmd.OpenQuery "qryExpirations"

Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim rstXL As DAO.Recordset
Dim rs As DAO.Recordset
Dim objMessage
Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT * FROM tblEmailOut WHERE Says = 1")
Set rstXL = db.OpenRecordset("SELECT [Full Name],SOEID,[WO End Date],GOC,[Business Contact SOEID] FROM Actions WHERE [WO End Date] Between Date() and Date()+1 ORDER BY Actions.[GOC] DESC")
Dim x As Object
    Set x = CreateObject("Excel.Application")
Dim w As Excel.Workbook
Dim s As Excel.Worksheet
Dim r As Excel.Range
Dim uniFileNm As String
Dim uniFileNm2 As String
Dim d As String
    d = "I:\My Documents\Projects\R2\Task 4 - GSDS Contractor DB\"
Set w = x.Workbooks.Open(d & "Expiring Resources Template.xls")
Set s = w.Sheets("ResExp")
Set r = s.Range("A2")

On Error Resume Next

'Get Outlook if it's running
Set oApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
    'Outlook wasn't running, start it from code
    Set oApp = CreateObject("Outlook.Application")
    Started = True
End If



Do While Not rst.EOF

'--------------Create Attachment--------------
uniFileNm2 = rstXL.Fields("GOC")

r.CopyFromRecordset rstXL

s.Columns("A:I").EntireColumn.AutoFit
s.Columns("A:I").Font.Size = 10

uniFileNm = d & "Expirations-" & uniFileNm2

w.SaveAs FileName:=uniFileNm, FileFormat:=51
    strPath = "I:\My Documents\Projects\R2\Task 4 - GSDS Contractor DB\Expirations-" & rstXL![Business Contact SOEID] & ".xls"
w.Close False
x.Quit

Set r = Nothing
Set s = Nothing
Set w = Nothing
Set x = Nothing

'---------------------------------------------

Set oItem = oApp.CreateItem(olMailItem)
    With oItem
        .To = rst!EmailAddress
        .Subject = "PLEASE READ: Impending Resource Expiration Notification"
        .Body = rst!EmailBody
        .Importance = olImportanceHigh
        .Attachment.Add = strPath
        'Send the email
        '.Send
        .Save
        .Close olPromptForSave
    End With
rst.MoveNext

Loop

db.Execute "UPDATE Actions SET [ApprovalSent] = Date() WHERE DateDiff(""d"", Date(), [WO End Date]) = 1"

rst.Close
Set rst = Nothing
Set db = Nothing
Set oItem = Nothing

If Started Then
    oApp.Quit
End If

End Sub

Thanks for the reply! I am doing all of what you said here except instead of grouping I'm using a SELECT DISTINCT and writing all the unique values to an array and using each array value in a new recordset query.

I am having one issue though - I am able to find all the unique values and run the second query. Once I run it, it finds all the records with that criteria and writes them to an excel file. It then creates an email and attaches the file. However, on the next iteration of the loop I get a runtime error 424 "Object required" on this line: "r.copyfromrecordset rsXL2"

Any help? I suspect there is an issue of opening a new workbook on the second iteration, but I could be wrong.

Public Sub ExpirationSub()

DoCmd.SetWarnings (WarningsOff)
DoCmd.OpenQuery "qryExpirations"

Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim rstXL As DAO.Recordset
Dim rs As DAO.Recordset
Dim rsXL As DAO.Recordset
Dim rsXL2 As DAO.Recordset
Dim uRS As DAO.Recordset
Dim objMessage
Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT * FROM tblEmailOut WHERE Says = 1")
Set rstXL = db.OpenRecordset("SELECT [Full Name],SOEID,[WO End Date],GOC,[Business Contact SOEID] FROM Actions WHERE [WO End Date] Between Date() and Date()+1")
Dim dPath As String
    dPath = "I:\My Documents\Projects\R2\Task 4 - GSDS Contractor DB\"
Dim x As Object
Dim w As Excel.Workbook
Dim s As Excel.Worksheet
Dim r As Excel.Range
    Set x = CreateObject("Excel.Application")
    Set w = x.Workbooks.Open(dPath & "Expiring Resources Template.xls")
    Set s = w.Sheets(1)
    Set r = s.Range("A2")
Dim uGOC() As String
Dim uFileNm, uFileDt, fnGOC As String
Dim c, i, j As Integer
    j = 1
    c = 1
    i = 1

'On Error Resume Next

'Get Outlook if it's running
Set oApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
    'Outlook wasn't running, start it from code
    Set oApp = CreateObject("Outlook.Application")
    Started = True
End If


Do While Not rst.EOF

'--------------Create Attachment--------------

If i = 1 Then
Set uRS = db.OpenRecordset("SELECT DISTINCT [GOC] FROM Actions WHERE [WO End Date] Between Date() and Date()+1")
    Do While c <= uRS.RecordCount
        If uRS!GOC <> "" Then
            ReDim Preserve uGOC(c)
            uGOC(c) = uRS!GOC
        End If
        uRS.MoveNext
        c = c + 1
    Loop
End If

fnGOC = uGOC(j)

Set rsXL2 = db.OpenRecordset("SELECT * FROM Actions WHERE [WO End Date] Between Date() and Date()+1 AND GOC=" & Chr(34) & fnGOC & Chr(34) & "")

r.CopyFromRecordset rsXL2

s.Columns("A:I").EntireColumn.AutoFit
s.Columns("A:I").Font.Size = 10

uFileNm = dPath & "Expirations-" & fnGOC & "-" & (Format(Date, "mmddyyyy")) & uFileDt

w.SaveAs FileName:=uFileNm, FileFormat:=56
    strPath = uFileNm & ".xls"
w.Close False
x.Quit

'---------------------------------------------

Set oItem = oApp.CreateItem(olMailItem)
    With oItem
        .To = rst!EmailAddress
        .Subject = "PLEASE READ: Impending Resource Expiration Notification"
        .Body = rst!EmailBody
        .Importance = olImportanceHigh
        .Attachments.Add (strPath)
        'Send the email
        '.Send
        .Save
        .Close olPromptForSave
    End With
rst.MoveNext
i = i + 1
j = j + 1
Loop

'db.Execute "UPDATE Actions SET [ApprovalSent] = Date() WHERE DateDiff(""d"", Date(), [WO End Date]) = 1"

rst.Close
Set rst = Nothing
Set db = Nothing
Set oItem = Nothing
Set r = Nothing
Set s = Nothing
Set w = Nothing
Set x = Nothing

If Started Then
    oApp.Quit
End If

End Sub