Code to group rows with same email address and attach to an email as new workbook returning 'runtime 424' error

Question

In theory, this code should group all rows with the same email address in the email address column into their own workbook, attach that workbook to an Outlook email, and send that email.

It generates a new workbook, but that's as far as I get before receiving a 'runtime 424 object required' error. I've played around with what needs to be an object here, etc, but no luck. Any ideas on where I'm going wrong?

Sub Button1_Click()
 Dim ws As Worksheet
    Dim lastrow As Long
    Dim emailColumn As Integer
    Dim emailDict As Object
    Dim cell As Range
    Dim email As Variant
    Dim newWb As Workbook
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim i As Integer


    ' Set the email column
    emailColumn = 7

    ' Create a dictionary to store email addresses as keys
    Set emailDict = CreateObject("Scripting.Dictionary")

    ' Set the worksheet to work with
    Set ws = ThisWorkbook.Sheets("Monthly Info")
    
        ' Find the last row in the worksheet
    lastrow = ws.Cells(ws.Rows.Count, emailColumn).End(xlUp).Row

   ' Loop through the rows and group data by email address
    For i = 2 To lastrow
    email = ws.Cells(i, emailColumn).Value
    On Error Resume Next
    If Not emailDict.Exists(email) Then
        ' Create a new workbook for this email
        Set newWb = Workbooks.Add
        newWb.Sheets(1).Name = "GI Data"
        emailDict(email) = newWb
    End If
    On Error GoTo 0
    ' Copy the entire row to the appropriate email's workbook
    ws.Rows(i).Copy Destination:=emailDict(email).Sheets("Data").Range("A" & emailDict(email).Sheets("Data").Cells(emailDict(email).Sheets("Data").Rows.Count, 1).End(xlUp).Row + 1)
Next i

    ' Create Outlook Application
    Set OutlookApp = CreateObject("Outlook.Application")

    ' Loop through the email workbooks and send them
    For Each email In emailDict.Keys
        Set newWb = emailDict(email)
        
        ' Save the workbook as a temporary file
        TempFilePath = Environ$("temp") & "\"
        TempFileName = "Data for " & email & ".xlsx"
        TempFilePathFile = TempFilePath & TempFileName
        newWb.SaveAs TempFilePathFile

        ' Create an email
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = email
            .Subject = "Reports"
            .Body = "Hello! Attached is a report of your monthly payments."
            .Attachments.Add TempFilePathFile
            .Send
        End With

        ' Close and delete the temporary workbook
        newWb.Close SaveChanges:=False
        Kill TempFilePathFile
    Next email

    ' Clean up
    Set emailDict = Nothing
    Set OutlookApp = Nothing
    Set OutlookMail = Nothing
End Sub

Answer 1

Option Explicit

Sub Button1_Click()
   
    ' Set the email column
    Const emailColumn = "G" ' 7
    
    Dim emailDict As Object, email, ws As Worksheet
    Dim TempFile As String
    Dim lastrow As Long, i As Long

    ' Create a dictionary to store email addresses as keys
    Set emailDict = CreateObject("Scripting.Dictionary")

    ' Set the worksheet to work with
    With ThisWorkbook.Sheets("Monthly Info")
    
        ' Find the last row in the worksheet
        lastrow = .Cells(.Rows.Count, emailColumn).End(xlUp).Row

        ' Loop through the rows and group data by email address
        For i = 2 To lastrow
            email = Trim(.Cells(i, emailColumn))
             
            If Not emailDict.Exists(email) Then
                ' Create a new workbook for this email
                emailDict.Add email, Workbooks.Add
            End If
            
            ' Copy the entire row to the appropriate email's workbook
            Set ws = emailDict(email).Sheets(1)
            .Rows(i).Copy Destination:=ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
        Next i
    End With
    
    ' Create Outlook Application
    Set OutlookApp = CreateObject("Outlook.Application")

    ' Loop through the email workbooks and send them
    For Each email In emailDict.Keys
    
        ' Save the workbook as a temporary file
        TempFile = Environ$("temp") & "\" & "Data for " & email & ".xlsx"
        emailDict(email).SaveAs TempFile
      
        ' Create an email
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = email
            .Subject = "Reports"
            .Body = "Hello! Attached is a report of your monthly payments."
            .Attachments.Add TempFile
            .Send
        End With

        ' Close and delete the temporary workbook
        emailDict(email).Close SaveChanges:=False
        Kill TempFile
    Next email

    ' Clean up
    Set emailDict = Nothing
    Set OutlookApp = Nothing
    Set OutlookMail = Nothing
End Sub