Excel VBA代码报'End If without Block If'错误，请求修复

编译错误原因 #

原代码中If Hname = "To" Then对应的End If位置错误，放在了Next R2之前，导致语法结构不匹配，触发"Compile Error: End If without Block If"错误。此外代码还存在单元格引用颠倒、变量初始化缺失、输出位置固定等逻辑问题，以下是修正后的完整代码：

修正后的代码 #

Sub CopyPasteII()
    ' 源文件路径
    Const FPTH As String = "C:\Users\Desktop\Misc\XYZ.xlsx"
    
    Dim Swbk As Workbook, Swsht As Worksheet, Dwbk As Workbook, Dwsht As Worksheet
    Dim Sfname As String, EmlidList As String, Hname As String, R As Long, C As Long, R2 As Long
    Dim arremailid() As Variant
    
    ' 设置目标工作簿和工作表
    Set Dwbk = ThisWorkbook
    Set Dwsht = Dwbk.Worksheets("Sheet1")
    Application.ScreenUpdating = False
    
    On Error GoTo Cleanup ' 错误处理
    
    ' 打开源工作簿
    Set Swbk = Workbooks.Open(FPTH, ReadOnly:=True)
    Set Swsht = Swbk.Sheets("XYZ")
    
    ' 遍历目标文件中的名称
    For R = 2 To Dwsht.Cells(Rows.Count, "A").End(xlUp).Row
        Sfname = Dwsht.Range("A" & R).Value
        ' 应用筛选器
        Swsht.Range("$A$1:$DC$1925").AutoFilter Field:=2, Criteria1:=Sfname
        Swsht.Range("$A$1:$DC$1925").AutoFilter Field:=5, Criteria1:="XYZ"
        
        EmlidList = "" ' 每次处理新名称时清空邮箱列表
        ' 遍历源文件中需要检查的列（从M列开始）
        For C = 1 To Swsht.Range("M1").End(xlToRight).Column
            Hname = Swsht.Cells(1, 12 + C).Value ' 12+C对应M列开始的列（M是第13列，12+1=13）
            
            If Hname = "To" Then
                ' 遍历当前列的行（从第2行开始，跳过表头）
                For R2 = 2 To Swsht.Cells(Rows.Count, 12 + C).End(xlUp).Row
                    ' 修正单元格引用：Cells(行,列)，原代码颠倒了行列
                    Dim cellVal As String
                    cellVal = Trim(Swsht.Cells(R2, 12 + C).Value)
                    
                    If cellVal <> "" Then ' 跳过空单元格
                        If EmlidList = "" Then
                            EmlidList = cellVal
                        Else
                            EmlidList = EmlidList & ";" & cellVal
                        End If
                    End If
                Next R2 ' 结束行循环
            End If ' 结束Hname判断的If块
        Next C ' 结束列循环
        
        ' 将邮箱列表转为数组并写入目标工作表（对应当前名称行的第3列）
        If EmlidList <> "" Then
            arremailid = Split(EmlidList, ";")
            ' 将数组写入单元格，这里选择横向写入，如需纵向可调整为Transpose(arremailid)
            Dwsht.Cells(R, 3).Resize(1, UBound(arremailid) + 1).Value = arremailid
        End If
    Next R ' 结束名称循环
    
Cleanup:
    ' 恢复筛选和屏幕更新
    If Not Swsht Is Nothing Then
        On Error Resume Next
        Swsht.ShowAllData
        On Error GoTo 0
    End If
    Application.ScreenUpdating = True
    ' 关闭源工作簿不保存
    If Not Swbk Is Nothing Then Swbk.Close SaveChanges:=False
    ' 提示错误
    If Err.Number <> 0 Then MsgBox "错误：" & Err.Description, vbExclamation
End Sub

关键修正点 #

• 修复编译错误：将If Hname = "To" Then对应的End If移至Next R2之后，匹配语法结构。
• 修正单元格引用：原代码中Swsht.Cells(12 + C, R2)颠倒了行列索引，改为Swsht.Cells(R2, 12 + C)（VBA中Cells语法为Cells(行号,列号)）。
• 变量初始化：每次处理新名称时清空EmlidList，避免不同名称的邮箱串在一起。
• 输出位置调整：将邮箱数组写入当前名称对应的行（Dwsht.Cells(R, 3)），而非固定第2行。
• 添加错误处理：增加On Error GoTo Cleanup，确保无论是否出错都能恢复屏幕更新、关闭源文件并清除筛选。
• 优化空值判断：使用Trim(cellVal) <> ""更准确地跳过空单元格（包括仅含空格的单元格）。
• 避免重复激活工作表：移除不必要的Activate和Select操作，直接通过对象引用操作工作表，提升代码效率。

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