基于Excel相邻单元格值构建Outlook收件人字符串（替代复选框）

需求说明：

• 从Excel工作表EmailRecipients的两列生成Outlook邮件收件人（TO字段）
• A列选择yes/no，决定对应B列的人员是否加入收件人列表
• 现有VBA代码逻辑错误，会将B列所有人员加入收件人，需修正

示例数据：

错误原因分析 #

原代码核心问题：当判断到A列某单元格为yes时，会循环遍历整个B列范围，把所有B列地址都追加到收件人字符串中，而非仅取当前行对应的B列地址。这会导致只要有一个yes，所有B列地址都会被重复加入，最终收件人列表混乱。

修正后的代码 #

Dim cell As Range, studentCell As Range, ci As Long, str As String 'all used for other code
Dim emailRng As Range, cl As Range, ce As Range
Dim sTo As String
Dim ws As Worksheet
Set ws = Worksheets("EmailRecipients")
' 取A2到B列最后一行的有效数据（跳过表头）
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim dataRng As Range
Set dataRng = ws.Range("A2:B" & lastRow)

' 遍历每一行数据
Dim rw As Range
For Each rw In dataRng.Rows
    Dim yesnostr As String
    yesnostr = LCase(rw.Cells(1, 1).Value) ' 统一转小写，避免大小写判断问题
    If yesnostr = "yes" Then
        ' 只取当前行的B列地址，追加到收件人字符串
        If sTo <> "" Then sTo = sTo & ";" ' 非空时才加分号，避免开头多余符号
        sTo = sTo & rw.Cells(1, 2).Value
    End If
Next rw


'VARIOUS OTHER CODE HERE TO BUILD A DIFFERENT STR FOR THE EMAIL BODY
'THANKS TO TIM WILLIAMS, DAVID, SHROTTER FOR CODE
   
'OUTLOOK EMAIL
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
    .To = sTo 'THE EMAIL RECIPIENTS WILL BE PUT HERE. 
    .CC = ""
    .BCC = ""
    .Subject = "Missing assignments report for lunches and more, " & Date & ", Q2"
    
    '****************************************************************************
    Dim wdDoc As Object
    Dim olinsp As Object
    
    Set olinsp = .GetInspector
    Set wdDoc = olinsp.WordEditor
    
    If Not IsEmpty(str) Then
        wdDoc.Range.InsertBefore str
    Else
        MsgBox prompt:="No cells meet the criteria"
        GoTo SafeExit
    End If
    '****************************************************************************
    .Display
    .Send
End With

Set OutMail = Nothing
Set OutApp = Nothing
Set wdDoc = Nothing
Set olinsp = Nothing
str = Empty

SafeExit:
On Error Resume Next
    
    If Not Application.EnableEvents Then
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If

On Error GoTo 0
Exit Sub

ClearError:
Debug.Print "Run-time error'" & Err.Number & "': " & Err.Description
Resume SafeExit

End Sub

'A DOUBLE CLICK OF A CELL IN ANOTHER SHEET STARTS THE OUTLOOK EMAIL PROCESS
Public Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Call ThisWorkbook.Check_Outlook
 
    With Target
       Select Case .Address
          Case "$A$1":
          Call Q2_Email_Missing_Assignments
      End Select
   End With

   Cancel = True
End Sub

关键修改点 #

1. 关联行数据：改为遍历每一行数据（dataRng.Rows），判断当前行A列值后，直接取同一行的B列地址，避免循环整个B列
2. 大小写兼容：用LCase()把A列值转成小写，统一判断为"yes"，避免大小写不一致的问题
3. 处理多余分号：只有当收件人字符串非空时才追加分号，避免最终字符串开头出现多余的;
4. 动态取数据范围：通过lastRow获取A列最后一行有效数据，避免固定范围（B1:B10）导致的遗漏或多余空白行

内容的提问来源于stack exchange，提问作者middleschoolteacher