Question

因此，我构建了一个用于发送1个列表的代码（在A列中）：单元格A1有一个区域，单元格A2，尽管最后一行具有需要该电子邮件的电子邮件地址。此代码对于A列效果很好。但是，如果在B-＃列中创建了一个列表（无论列数多少），我可以添加到此代码上并使其创建与列数一样多的电子邮件，并将其发送到第2行下方的人员列表。

换句话说，我们是否可以对第一行中具有值的每一列说一句话，然后创建并发送电子邮件并将其发送给它下面的其他所有人？

谢谢

Sub emailfromcolumns()

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
LastRow = Range("A" & rows.Count).End(xlUp).Row


'email recipients are in row 2 to the last row
For i = 2 To LastRow
If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If

Next

MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
        & "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
        & "<li>Thanks,<br><br>" _
        & "Thank you, Pricing Team<br><br>" _


Set olApp = GetObject(Class:="Outlook.Application")

If olApp Is Nothing Then

Set olApp = CreateObject(Class:="outlook.application")

End If

Set olMail = olApp.CreateItem(0)

With olMail
    .To = Namelist
    .Subject = Range("A1").Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
    .display
    .HTMLBody = MailMessage
    .Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Range("A1").Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
    .Save
    .Close 1
    End With

Set olMail = Nothing
Set olApp = Nothing

Application.ScreenUpdating = True
End Sub

Answer 1

我会让您现有的例程接受列号，以便您可以将任何列传递给它，然后它将适用于该列，例如

Sub emailfromcolumns(COL As Long)

因此，您只需致电emailfromcolumns(1)来发送A列的电子邮件，emailfromcolumns(2)来发送B列的电子邮件，等等。

然后，您可以创建第二个子例程，以找出有多少列，然后循环遍历所有列，并调用现有例程：

Sub loopit()
Dim lastColumn As Long
Dim x As Long
    lastColumn = Sheets("Recipients").Cells(1, Sheets("Recipients").Columns.Count).End(xlToLeft).Column
    For x = 1 To lastColumn
        emailfromcolumns (x)
    Next x
End Sub

这意味着您对现有代码所要做的就是用变量COL替换对“ A”列的任何引用-有四行：

更改

LastRow = Range("A" & rows.Count).End(xlUp).Row

到

LastRow = Cells(Rows.Count, COL).End(xlUp).Row

更改

If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If

到

If Cells(2, COL).Value2 <> "" Then
    Namelist = Namelist & ";" & Cells(i, COL).Value2
End If

，最后两行在电子邮件位内：

.Subject = Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")

最重要的是，您的代码中有一些危险的部分，您只是在参考Range而未声明范围是在哪张纸上...下面是完整版本，其中包含有关差异的注释：< / p>

Sub emailfromcolumns(COL As Long)

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
Dim WS As Worksheet ' Declare a worksheet object
Set WS = ThisWorkbook.Worksheets("Recipients") ' set the worksheet object WS to "Recipients" for easy reference

LastRow = WS.Cells(WS.Rows.Count, COL).End(xlUp).Row ' last row now definitely referencing "Recipients" thanks to WS

'email recipients are in row 2 to the last row
' changed your "A2" check to outside the loop, don't need to check it each time
If WS.Cells(2, COL).Value2 <> "" Then
    For i = 2 To LastRow
        Namelist = Namelist & ";" & WS.Cells(i, COL).Value2
    Next i
End If

MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
        & "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
        & "<li>Thanks,<br><br>" _
        & "Thank you, Pricing Team<br><br>" _


Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject(Class:="outlook.application")

Set olMail = olApp.CreateItem(0)

With olMail
    .To = Namelist
    .Subject = WS.Cells(1, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
    .display
    .HTMLBody = MailMessage
    .Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & WS.Cells(1, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
    .Save
    .Close 1
End With

Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True ' You didn't have anywhere that says Application.ScreenUpdating = False ?

End Sub

Answer 2

Sub emailfromcolumns()

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim z As Long
Dim LastRow As Long
Dim Namelist As String
Dim colCount As Long

'How Many Columns?
colCount = 4

'Loop through columns
For z = 1 To colCount

'email recipients are in row 2 to the last row
Namelist = vbNullString
With Worksheets("Recipients")
    LastRow = .Cells(.Rows.Count, z).End(xlUp).Row
    For i = 2 To LastRow
        If .Cells(i, z).Value <> "" Then
            Namelist = Namelist & ";" & .Cells(i, z).Value
        End If
    Next
End With

'Only create message if emails exist?
If Len(Namelist) > 0 Then

    MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
            & "<li>Please let me know if there is anything else you need or any changes you would like to see.<br> " _
            & "<br>" _
            & "<li>Thanks,<br><br>" _
            & "Thank you, Pricing Team<br><br>" _

    Set olApp = GetObject(Class:="Outlook.Application")

    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="outlook.application")
    End If

    Set olMail = olApp.CreateItem(0)

    With olMail
        .To = Namelist
        .Subject = Sheets("Recipients").Cells(1, z).Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
        .display
        .HTMLBody = MailMessage
        .Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(1, z).Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
        .Save
        .Close 1
    End With

    Set olMail = Nothing
    Set olApp = Nothing

End If

Next z

Application.ScreenUpdating = True

End Sub

VBA-通过多列重复发送电子邮件功能

2 个答案: