如何将特定值的单元格数据复制到其他工作表？VBA代码求助

原代码存在的问题 #

• 循环逻辑错误：遍历单元格时，只要遇到值为1的单元格，就把Sheet1的整个A2:A81区域赋值给Sheet3的C2:C81，最终只会覆盖出最后一次的结果，完全没实现“只复制值为1的单元格”的需求
• 未处理值为2的情况，也没有将值为1的数据放到Sheet2的A列

基础循环版代码（适合新手理解） #

Sub Mandat1_Click()
    Dim wsSource As Worksheet
    Dim wsDest1 As Worksheet
    Dim wsDest2 As Worksheet
    Dim sourceRange As Range
    Dim cell As Range
    Dim lastRowDest1 As Long
    Dim lastRowDest2 As Long
    
    ' 绑定工作表对象，用表名代替索引，避免工作表顺序变动出错
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDest1 = ThisWorkbook.Sheets("Sheet2")
    Set wsDest2 = ThisWorkbook.Sheets("Sheet3")
    
    ' 清空目标表A列的旧数据（从第2行开始，假设第1行是表头）
    wsDest1.Range("A2:A" & wsDest1.Cells(wsDest1.Rows.Count, "A").End(xlUp).Row).ClearContents
    wsDest2.Range("A2:A" & wsDest2.Cells(wsDest2.Rows.Count, "A").End(xlUp).Row).ClearContents
    
    ' 动态获取Sheet1中A列有数据的最后一行，不用固定A2:A81
    Set sourceRange = wsSource.Range("A2:A" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row)
    
    ' 遍历每个源数据单元格
    For Each cell In sourceRange
        ' 获取目标表A列的下一个空行位置
        lastRowDest1 = wsDest1.Cells(wsDest1.Rows.Count, "A").End(xlUp).Row + 1
        lastRowDest2 = wsDest2.Cells(wsDest2.Rows.Count, "A").End(xlUp).Row + 1
        
        Select Case cell.Value
            Case 1
                ' 将值为1的单元格内容复制到Sheet2的A列空行
                wsDest1.Cells(lastRowDest1, "A").Value = cell.Value
            Case 2
                ' 将值为2的单元格内容复制到Sheet3的A列空行
                wsDest2.Cells(lastRowDest2, "A").Value = cell.Value
        End Select
    Next cell
End Sub

高效筛选版代码（适合数据量大的场景） #

如果Sheet1的A列数据很多，循环遍历会比较慢，用AutoFilter筛选后批量复制更高效：

Sub Mandat1_Click_Fast()
    Dim wsSource As Worksheet
    Dim wsDest1 As Worksheet
    Dim wsDest2 As Worksheet
    Dim sourceRange As Range
    Dim lastRowSource As Long
    
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDest1 = ThisWorkbook.Sheets("Sheet2")
    Set wsDest2 = ThisWorkbook.Sheets("Sheet3")
    
    ' 清空目标表旧数据
    wsDest1.Range("A2:A" & wsDest1.Cells(wsDest1.Rows.Count, "A").End(xlUp).Row).ClearContents
    wsDest2.Range("A2:A" & wsDest2.Cells(wsDest2.Rows.Count, "A").End(xlUp).Row).ClearContents
    
    ' 获取Sheet1 A列最后一行有数据的位置
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set sourceRange = wsSource.Range("A1:A" & lastRowSource) ' 包含表头
    
    ' 筛选值为1的行，复制到Sheet2的A列
    sourceRange.AutoFilter Field:=1, Criteria1:=1
    sourceRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy wsDest1.Cells(wsDest1.Rows.Count, "A").End(xlUp).Offset(1)
    wsSource.AutoFilterMode = False ' 关闭筛选
    
    ' 筛选值为2的行，复制到Sheet3的A列
    sourceRange.AutoFilter Field:=1, Criteria1:=2
    sourceRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy wsDest2.Cells(wsDest2.Rows.Count, "A").End(xlUp).Offset(1)
    wsSource.AutoFilterMode = False
End Sub

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