excel 将具有相同电子邮件地址的行分组并作为新工作簿附加到电子邮件的代码返回“运行时424”错误

a64a0gku  于 2023-11-20  发布在  其他
关注(0)|答案(1)|浏览(101)

理论上,这段代码应该将电子邮件地址列中具有相同电子邮件地址的所有行分组到它们自己的工作簿中,将该工作簿附加到Outlook电子邮件,并发送该电子邮件。
它生成了一个新的工作簿,但这是我在收到“运行时424 object required”错误之前所得到的。我已经在这里尝试了什么需要成为一个对象,等等,但没有运气。我哪里出错了?

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

字符串

bkkx9g8r

bkkx9g8r1#

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

字符串

相关问题