VBA遍历多Excel工作簿匹配表头合并列 报对象变量未设置错误

触发「对象变量或With块变量未设置」错误的核心原因是Range.Find方法未检索到匹配内容时会返回Nothing，此时直接链式调用.Row/.Column属性就会报错，对应原代码的两处风险点：

• 遍历工作表时仅排除了名为"Sheet1"的表，遇到其他完全空白的工作表时，Cells.Find("*", ...)找不到任何有效单元格，直接取最后一行行号触发报错
• 第一行查找"MD"表头时未做非空判断，若工作表非空但第一行不存在"MD"表头，Rows(1).Find("MD", ...)返回Nothing，取列号时同样会触发该错误

另外原代码存在两处逻辑漏洞：

• 定义了colArr数组存储匹配表头，但循环时硬编码查找"MD"，后续修改匹配目标时无法通过修改数组值直接生效
• 取粘贴起始位置时未明确指定目标工作表，跨工作簿调用Rows.Count时会默认读取当前激活工作表的行数，容易出现粘贴位置错乱
• 声明了sht变量但全程未使用，属于冗余代码

Sub MultipleSimilarColinto_1()
    Dim xFd         As FileDialog
    Dim xFdItem     As String
    Dim xFileName   As String
    Dim wbk         As Workbook
    Dim twb         As Workbook
    Dim LastRow     As Long
    Dim ws          As Worksheet
    Dim desWS       As Worksheet
    Dim colArr      As Variant
    Dim i           As Long
    Dim rngFound    As Range
    Dim targetCol   As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ActiveWindow.View = xlNormalView
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    Set twb = ActiveWorkbook
    ' 配置目标工作表，如需修改目标表直接改此处表名
    Set desWS = twb.Sheets("Sheet1")
    ' 配置需要匹配的表头，如需匹配SouthRecord直接替换数组内文本即可，支持多表头配置
    colArr = Array("MD")
    
    If xFd.Show Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
    Else
        Beep
        Exit Sub
    End If
    
    xFileName = Dir(xFdItem & "*.xlsx")
    Do While xFileName <> ""
        Set wbk = Workbooks.Open(xFdItem & xFileName)
        For Each ws In wbk.Sheets
            ' 跳过空表
            Set rngFound = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            If rngFound Is Nothing Then GoTo NextSheetProcess
            LastRow = rngFound.Row
            
            ' 遍历要匹配的表头
            For i = LBound(colArr) To UBound(colArr)
                ' 查找目标表头列
                Set rngFound = ws.Rows(1).Find(colArr(i), LookIn:=xlValues, lookat:=xlWhole)
                If Not rngFound Is Nothing Then
                    targetCol = rngFound.Column
                    ' 存在有效数据时才执行复制
                    If LastRow >= 2 Then
                        ws.Range(ws.Cells(2, targetCol), ws.Cells(LastRow, targetCol)).Copy _
                            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
                    End If
                End If
            Next i
NextSheetProcess:
        Next ws
        wbk.Close SaveChanges:=False
        xFileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "数据合并完成", vbInformation
End Sub

• 修改匹配表头直接编辑colArr = Array("MD")即可，比如要匹配"SouthRecord"就改成colArr = Array("SouthRecord")，需要同时匹配多列就写成colArr = Array("MD", "SouthRecord")，代码会自动把所有匹配到的列数据按顺序追加到目标列
• 代码默认将合并后的数据写入当前运行宏的工作簿Sheet1的A列，如需修改目标位置，调整Set desWS = twb.Sheets("Sheet1")的表名、以及粘贴代码里的"A"列标即可
• 运行后弹出文件夹选择框，选中存放待合并Excel的文件夹即可自动处理，会自动跳过空工作表、无目标表头的工作表，不会触发对象未定义错误
• 遍历打开的工作簿仅做数据读取，不需要保存修改，所以关闭文件时设置为不保存，避免无谓的文件修改时间更新

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