如何使用VBA读取Excel工作表选中项并写入另一工作表指定位置

你原有硬编码逐个判断的写法不仅冗余无法复用，逐单元格读写的性能也极低，优化方案采用数组批量操作，仅两次和工作表交互，效率更高且适配动态数据规模。

实现思路 #

• 一次性读取Sheet1的所有输入项和标记数据到数组，避免逐单元格读取的性能损耗
• 遍历数组筛选所有标记为X的输入项，同时兼容大小写输入的X
• 将筛选后的结果一次性写入Sheet2指定位置，减少多次写入操作的开销
• 自动适配输入项数量变动，新增/删除输入项无需修改代码逻辑

优化后VBA代码 #

Sub 导出选中的输入项()
    ' 变量定义
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim sourceArr As Variant, resultArr As Variant
    Dim lastRow As Long, i As Long, resultCount As Long
    ' 配置参数，可根据实际需求修改
    Const START_COL As String = "B" ' 输出起始列
    Const START_ROW As Long = 2 ' 输出起始行
    
    ' 绑定工作表
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    
    ' 获取Sheet1输入项的最后有效行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    ' 读取数据源到数组，默认第1行为表头，从第2行开始读取
    sourceArr = wsSource.Range("A2:B" & lastRow).Value
    
    ' 统计符合条件的项数，初始化结果数组
    resultCount = 0
    For i = 1 To UBound(sourceArr, 1)
        If UCase(Trim(sourceArr(i, 2))) = "X" Then ' 忽略大小写和前后空格匹配X
            resultCount = resultCount + 1
        End If
    Next i
    
    ' 无符合条件项直接退出
    If resultCount = 0 Then
        MsgBox "未找到标记为X的输入项"
        Exit Sub
    End If
    
    ' 填充结果数组
    ReDim resultArr(1 To resultCount, 1 To 1)
    resultCount = 0
    For i = 1 To UBound(sourceArr, 1)
        If UCase(Trim(sourceArr(i, 2))) = "X" Then
            resultCount = resultCount + 1
            resultArr(resultCount, 1) = sourceArr(i, 1)
        End If
    Next i
    
    ' 清空目标区域原有数据，一次性写入结果
    wsTarget.Range(START_COL & START_ROW & ":" & START_COL & START_ROW + resultCount - 1).ClearContents
    wsTarget.Range(START_COL & START_ROW).Resize(resultCount, 1).Value = resultArr
    ' 可选：添加输出列表头
    wsTarget.Range(START_COL & START_ROW - 1).Value = "Outputs"
End Sub

使用说明 #

• 开头的START_COL和START_ROW常量可以直接修改，调整输出的起始位置
• 代码自动忽略X的大小写和前后空格，避免用户输入小写x、带空格的X识别失败的问题
• 自动适配Sheet1的输入项数量，不管有多少个输入项都能正常运行，不需要修改逻辑
• 写入前自动清空目标位置的旧数据，不会出现数据残留

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