循环遍历每列

我正在尝试编写一个VBA代码，可以自动将文档发送给多个收件人。 我的Excel电子表格看起来像这样：

Name Report #1 Report #2 Report #3 Recipient Email 1 Email 1 Email 1 Email 2 Email 2 Email 2 Email 3 Email 3 Email 3 Email 4 Email 4 Email 5 

代码使用单元格B1来查找报告名称并将其find驱动器上。 然后将它作为附件发送给B栏中的收件人。到目前为止，我已经能够做到这一点：

 Option Explicit Sub Email_Report() 'Purpose: AustrTomate sending of reports via email to a list of specified Recipients Dim OutApp As Object Dim OutMail As Object Dim EmailRng As Range, Recipient As Range Dim strTo As String Set EmailRng = Worksheets("Sheets1").Range("B2:B20") For Each Recipient In EmailRng strTo = strTo & ";" & Recipient.Value Next strTo = Mid(strTo, 2) Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .strTo = strTo .CC = "" .BCC = "" .Subject = "Report Name Here" .Body = "Body text here" .Attachments.Add ("File location here") .Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing End Sub 

但我很难find一个优雅的解决scheme，使代码继续到列C，D等做同样的事情。 任何人都可以把我推向正确的方向吗？

Answer 1

尝试用这样的东西replace你的For Each语句。 这将滚动第二行中的单元格，所以我猜你将需要添加另一个循环来滚动所有的行，一旦你有这个工作。

注：我切换到strTo因为To我一个错误。 这是VBA中的保留关键字。

新的循环来获取电子邮件：

 For column = 2 To EmailRng.Cells.Count If Cells(2, column) <> "" Then 'Don't bother cell is blank 'Don't add a semicolon with the first address If strTo = "" Then strTo = Cells(2, column) Else strTo = strTo & ";" & Cells(2, column) End If End If Next 

Answer 2

您不需要循环收件人，使用Join withjoin值; 作为这样的分隔符：

 Sub Email_Report() 'Purpose: AustrTomate sending of reports via email to a list of specified Recipients Dim OutApp As Object, OutMail As Object, EmailRng As Range, Recipient As Range, strTo As String, X As Long Set EmailRng = Worksheets("Sheets1").Range("B2:B20") Set OutApp = CreateObject("Outlook.Application") For X = 1 To 3 'Number of columns to poll across strTo = Join(Application.Transpose(Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Offset(0, X - 1)), ";") 'Get all values in column and populate to strTo without looping Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .strTo = strTo .CC = "" .BCC = "" .Subject = "Report Name Here" .Body = "Body text here" .Attachments.Add ("File location here") .Send End With On Error GoTo 0 Set OutMail = Nothing Next Set OutApp = Nothing End Sub