使用相同电子邮件地址对行进行分组并附加到电子邮件的代码，因为新工作簿返回“运行时 424”错误-解网

问：

从理论上讲，此代码应将电子邮件地址列中具有相同电子邮件地址的所有行分组到其自己的工作簿中，将该工作簿附加到 Outlook 电子邮件，然后发送该电子邮件。

它生成一个新工作簿，但这是我在收到“需要运行时 424 对象”错误之前得到的。我在这里玩过需要成为对象的东西，等等，但没有运气。关于我哪里出错了，有什么想法吗？


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

Excel VBA 电子邮件 Outlook

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

使用相同电子邮件地址对行进行分组并附加到电子邮件的代码，因为新工作簿返回“运行时 424”错误

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

评论

评论