理论上,这段代码应该将电子邮件地址列中具有相同电子邮件地址的所有行分组到它们自己的工作簿中,将该工作簿附加到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
字符串
1条答案
按热度按时间bkkx9g8r1#
字符串