求助：VBA按行标题定位列并复制匹配行至新工作表

问题说明 #

需要实现的功能：在Excel第2行中查找标题“Country”，定位对应整列，筛选出与指定单元格CountryInput匹配的行并复制到新工作表。现有VBA代码无法正常运行，尤其列引用存在问题，原代码如下：

Sub Extract_Country()

Dim CountryInput As Variant
Dim CountryCol As Range
Dim i As Long
Dim CopyRange As Range
Dim test As Single

CountryInput = Range("CountryInput")

startrow = 1
endrow = 2000
startcol = 1
number_of_columns = 200

'Take Away Merge
Rows("1:1").Select
With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Interior.ColorIndex = xlNone
    End With


Set CountryCol = Range("2:2").Find("Country")


'Copy Rows that Equal CountryInput
For i = 1 To endrow
    test = Cells(i, CountryCol)  'look in every row
    compare = StrComp(test, CountryInput, vbTextCompare)  'compare to the look up value
    
    If compare = 0 Then
        CopyRange = Union(CopyRange, ActiveRow)
    End If
    
Next i


'Create New Sheet
Sheets.Add After:=ActiveSheet.Name = CountryInput & "1"

原代码问题分析 #

• 列引用错误：CountryCol是Range对象，Cells(i, CountryCol)的写法不合法，需用CountryCol.Column获取列号
• 变量类型不匹配：test被声明为Single（单精度浮点数），但Country的值为文本，会导致类型转换错误
• CopyRange初始化问题：首次调用Union时CopyRange为Nothing，直接赋值会报错
• ActiveRow无效：ActiveRow不是合法的Range对象，需明确指定要复制的行范围
• 工作表创建语法错误：Sheets.Add After:=ActiveSheet.Name = ...语法错误，需拆分新增和命名操作
• 无错误处理：未处理CountryCol未找到、CountryInput为空的情况，会导致代码崩溃
• 变量未声明：startrow、endrow等变量未声明，易引发逻辑错误

修正后的代码 #

Option Explicit

Sub Extract_Country()
    Dim CountryInput As Variant
    Dim CountryCol As Range
    Dim i As Long
    Dim CopyRange As Range
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim startrow As Long, endrow As Long
    Dim startcol As Long, number_of_columns As Long
    
    ' 指定源工作表
    Set wsSource = ActiveSheet
    
    ' 获取筛选值并校验
    CountryInput = wsSource.Range("CountryInput").Value
    If IsEmpty(CountryInput) Then
        MsgBox "请指定要筛选的国家！", vbExclamation
        Exit Sub
    End If
    
    ' 定义数据范围参数
    startrow = 3 ' 标题行是第2行，数据从第3行开始
    endrow = 2000
    startcol = 1
    number_of_columns = 200
    
    ' 取消第1行合并单元格
    With wsSource.Rows("1:1")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Interior.ColorIndex = xlNone
    End With
    
    ' 查找Country列（精确匹配）
    Set CountryCol = wsSource.Range("2:2").Find(What:="Country", LookIn:=xlValues, LookAt:=xlWhole)
    If CountryCol Is Nothing Then
        MsgBox "未找到标题为'Country'的列！", vbExclamation
        Exit Sub
    End If
    
    ' 筛选匹配的行
    For i = startrow To endrow
        ' 忽略大小写比较单元格值
        If StrComp(wsSource.Cells(i, CountryCol.Column).Value, CountryInput, vbTextCompare) = 0 Then
            ' 初始化或合并复制范围
            If CopyRange Is Nothing Then
                Set CopyRange = wsSource.Range(wsSource.Cells(i, startcol), wsSource.Cells(i, startcol + number_of_columns - 1))
            Else
                Set CopyRange = Union(CopyRange, wsSource.Range(wsSource.Cells(i, startcol), wsSource.Cells(i, startcol + number_of_columns - 1)))
            End If
        End If
    Next i
    
    ' 复制匹配内容到新工作表
    If Not CopyRange Is Nothing Then
        ' 创建新工作表
        Set wsNew = ThisWorkbook.Sheets.Add(After:=wsSource)
        
        ' 设置工作表名称（处理重复情况）
        On Error Resume Next
        wsNew.Name = CountryInput & "1"
        If Err.Number <> 0 Then
            wsNew.Name = CountryInput & "_" & Format(Now(), "YYYYMMDDHHMMSS")
        End If
        On Error GoTo 0
        
        ' 复制标题行
        wsSource.Range(wsSource.Cells(2, startcol), wsSource.Cells(2, startcol + number_of_columns - 1)).Copy wsNew.Cells(1, 1)
        ' 复制筛选后的行
        CopyRange.Copy wsNew.Cells(2, 1)
        ' 自动调整列宽
        wsNew.Columns.AutoFit
    Else
        MsgBox "未找到匹配指定国家的行！", vbInformation
    End If
End Sub

关键改进点 #

• 添加Option Explicit强制变量声明，避免未声明变量引发的错误
• 明确指定源工作表，防止ActiveSheet切换导致的逻辑混乱
• 增加错误处理：校验筛选值是否为空、Country列是否存在
• 修正列引用方式，使用CountryCol.Column获取正确列号
• 正确初始化CopyRange，处理首次合并范围的情况
• 拆分工作表创建与命名操作，同时处理名称重复的异常
• 复制标题行到新工作表，使结果数据结构完整
• 新增自动调整列宽，提升输出可读性

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