Question

有人可以用下面的代码帮我吗？这是一段代码，用于复制来自＆＃34; Sheet1＆＃34;的电子邮件ID列表。细胞＆＃34; B2＆＃34;到＆＃34; n＆＃34;有数据的行数。

我面临两个问题。

1）HTMLBody文本不会复制到电子邮件中 2）Sheet1，B2以后可用的电子邮件收件人列表未被复制到电子邮件收件人列表中（＆＃34; To＆＃34; list）。

提前致谢！

Sub MeetingMacro()
'MsgBox Hour(Now)
If Weekday(Now, vbMonday) >= 6 And Hour(Now) > 12 Then
Exit Sub
End If

Application.ScreenUpdating = False

Dim pt As PivotTable
Set pt = ThisWorkbook.Sheets("Sheet2").PivotTables("PivotTable")
pt.RefreshTable
Application.CalculateUntilAsyncQueriesDone
Call saveAsXlsx1
Application.CalculateUntilAsyncQueriesDone
Call savefile
Application.CalculateUntilAsyncQueriesDone
Call Send_Range
'Call Send_Range


End Sub

Sub Send_Range()

   Dim TBL As ListObject
     ThisWorkbook.Activate

   ThisWorkbook.EnvelopeVisible = False
   ThisWorkbook.Sheets("Sheet2").Range("A1:B30").Select
    ThisWorkbook.Activate
   With ActiveSheet.MailEnvelope

            SDest = ""
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
           If SDest = "" Then
               SDest = Cells(iCounter, 3).Value
               SDest.Value.Select
           Else
               SDest = SDest & ";" & Cells(iCounter, 3).Value
           End If
       Next iCounter

      .Item.To = SDest
      .Item.CC = "someone@example.com"
      .Item.Subject = "[URGENT] Meeting has been cancelled. "
      .Item.HTMLBody = "Hello," & vbCrLf & "Meeting has been cancelled. Fresh invite will be sent soon.” & vbCrLf & "Regards"
      .Item.Attachments.Add "C:\Attachment.xlsx" 'ActiveWorkbook.FullName
      .Item.Send
   End With

   'MsgBox (TimeOfDay)
End Sub


'MsgBox (TimeOfDay)
Sub savefile()
 Application.ScreenUpdating = False
     ThisWorkbook.Activate
     Application.ScreenUpdating = True
ThisWorkbook.Save
End Sub
Sub saveAsXlsx1()
ThisWorkbook.Worksheets(Array("Sheet2")).Copy
Application.DisplayAlerts = False
 ActiveSheet.Shapes.Range("FetchData").Delete
ActiveWorkbook.SaveAs Filename:="C:\Attachment.xlsx"
ActiveWorkbook.Close
End Sub

Sub Meeting4()
ThisWorkbook.Application.DisplayAlerts = False
ActiveWorkbook.Save
ThisWorkbook.Close
End Sub

Answer 1

假设Sheet1中有包含电子邮件地址的单元格B2：B30（全部在同一列中）。你想要的是抓住这些单元格中的值，并将它们变成一维数组 - 这样就完成了：

Dim values As Variant
values = Application.WorksheetFunction.Transpose(Sheet1.Range("B2:B30").Value)

使用一维电子邮件地址数组，您只需将其转换为String即可。 Join函数正是为此而创建的：

Dim recipients As String
recipients = Join(values, ";")

这就是全部！ ...假设单元格 all 包含电子邮件地址字符串。如果一个单元格包含错误值，则会出现问题。如果有空白，期望空白（尽管不应该有所作为）。如果要抓住的范围没有刻在石头上，研究如何使其更具活力。

HtmlBody期待包含HTML标记的HTML编码字符串。如果您只有纯文本，请改用Body属性。

将电子邮件列表复制到Outlook

1 个答案: