Excel VBA中Do While循环仅返回首个指定值问题求助

问题根因 #

你的代码核心错误是行号引用基准不统一，其次是边界判断缺失：

• Do While判断条件里用的Range("B" & n)、Range("A" & n)是直接读取当前活动工作表的整列单元格，而取值用的xRg.Cells(n, 21)是读取你手动选中区域的单元格。只要你选中的区域不是从工作表第1行开始，两个引用的行号就完全错位，导致判断逻辑和取值对应不上，大部分情况循环跑一次就不满足条件退出。
• 缺少n的上界判断，当n超出你选中区域的总行数时，xRg.Cells(n,21)会报错，而你开启的On Error Resume Next直接吞掉了错误，表现为取不到后续值。
• 你设置的n = i + 2起始值逻辑有问题，正常当前商家对应xRg的第i行，附属违规记录应该从i+1行开始判断。

解决方案 #

把所有单元格引用统一到你选中的xRg区域，补充边界判断，修正循环起始值即可，修正后完整代码如下：

#If VBA7 And Win64 Then
  Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                     ByVal hwnd As LongPtr, ByVal lpOperation As String, _
                     ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                     ByVal nShowCmd As Long) As LongPtr
#Else
  Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                     ByVal hwnd As Long, ByVal lpOperation As String, _
                     ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                     ByVal nShowCmd As Long) As Long
#End If
Sub SendEMail()
Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Long
Dim n As Long
Dim xRg As Range
Dim xTxt As String

xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 21 Then
    MsgBox " Regional format error, please check", , "Kutools for Excel"
    Exit Sub
End If

For i = 1 To xRg.Rows.Count
    ' 仅处理商家首行（A列有值且有邮箱的行）
    If xRg.Cells(i, 1).Value <> "" And InStr(1, xRg.Cells(i, 13).Value, "@") > 0 Then
        xEmail = xRg.Cells(i, 13)
        xSubj = "MAPP Violation"
        xMsg = "Text" & vbCrLf
        
        ' 从当前行下一行开始遍历附属违规记录
        n = i + 1
        ' 增加边界判断：n不超过选中区域总行数
        Do While n <= xRg.Rows.Count And xRg.Cells(n, 2).Value <> "" And xRg.Cells(n, 1).Value = ""
            xMsg = xMsg & xRg.Cells(n, 21).Value & vbCrLf
            n = n + 1
        Loop
        
        ' 编码URL参数
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
        
        xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    End If
Next
End Sub

额外优化建议 #

SendKeys稳定性很差，很容易出现发送失败、焦点错位的问题，如果你的默认邮件客户端是Outlook，建议直接调用Outlook对象模型生成和发送邮件，可靠性高很多，也不需要手动编码URL参数。

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