请求编写VBA代码：将Sheet1与Sheet2合并至Sheet3并去除N/A值

需求说明：
我有两个表头结构相同的工作表Sheet1和Sheet2，两者的数据量会动态变化。需要编写VBA代码完成以下操作：

1. 将Sheet1中所有不含N/A值的有效行复制到Sheet3
2. 接着将Sheet2中所有不含N/A值的有效行复制到Sheet3的下一个可用行位置

我目前编写的代码如下：

Sub cpynpst1()
Dim sh1 As Worksheet, sh5 As Worksheet, sh2 As Worksheet, LR As Long, rng As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
LR = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh1.Range("A2:A" & LR)
rng.EntireRow.Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
End Sub

修正后的完整代码 #

Sub MergeValidDataToSheet3()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow As Long, targetRow As Long
    Dim sourceRange As Range
    
    ' 定义工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    ' 若Sheet3不存在则新建，否则清空原有数据（保留表头）
    On Error Resume Next
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    On Error GoTo 0
    If ws3 Is Nothing Then
        Set ws3 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws3.Name = "Sheet3"
        ' 复制表头（从Sheet1复制第一行）
        ws1.Rows(1).Copy ws3.Rows(1)
    Else
        ' 清空Sheet3除表头外的所有数据
        ws3.Rows("2:" & ws3.Rows.Count).ClearContents
    End If
    targetRow = 2 ' 从第二行开始粘贴数据（第一行是表头）
    
    ' 处理Sheet1的数据：复制不含N/A的行到Sheet3
    With ws1
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lastRow >= 2 Then
            ' 筛选出不含N/A的行（假设N/A是单元格错误值，若为文本"N/A"需调整条件）
            On Error Resume Next
            Set sourceRange = .Range("A2:" & .Cells(lastRow, .Columns.Count).Address).SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers)
            On Error GoTo 0
            If Not sourceRange Is Nothing Then
                sourceRange.EntireRow.Copy ws3.Cells(targetRow, 1)
                ' 更新目标行位置
                targetRow = ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row + 1
            End If
        End If
    End With
    
    ' 处理Sheet2的数据：复制不含N/A的行到Sheet3
    With ws2
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lastRow >= 2 Then
            On Error Resume Next
            Set sourceRange = .Range("A2:" & .Cells(lastRow, .Columns.Count).Address).SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers)
            On Error GoTo 0
            If Not sourceRange Is Nothing Then
                sourceRange.EntireRow.Copy ws3.Cells(targetRow, 1)
            End If
        End If
    End With
    
    ' 取消复制模式
    Application.CutCopyMode = False
    MsgBox "数据合并完成！", vbInformation
End Sub

代码关键说明 #

• 工作表处理：自动检测Sheet3是否存在，不存在则新建并复制表头；存在则清空原有数据（保留表头），避免重复数据堆积
• N/A值过滤：使用SpecialCells筛选出常量文本和数值单元格，自动排除错误值类型的N/A；如果你的N/A是文本格式，可将筛选条件改为xlTextValues并添加判断<> "N/A"
• 动态定位行：每次复制后更新Sheet3的下一个可用行，确保数据连续不覆盖
• 错误处理：添加On Error Resume Next避免因无有效数据导致代码报错

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