基于A列值复制非空白行至对应工作表的VBA实现求助

原代码问题梳理 #

• 变量Q未声明，会触发隐式变量错误
• 变量I未初始化就用于判断If I = 1 Then，逻辑无效
• 直接复制整行，不符合"仅复制非空白内容"的需求
• 仅处理了"Hello"的情况，未覆盖"Bye"和"Greetings"的需求

单个模块实现（一次性处理所有规则） #

这个版本会遍历Data表的行，根据A列值将每行非空白内容复制到对应工作表的下一行：

Sub CopyRowsByCategory()
    Dim wsData As Worksheet
    Dim wsHello As Worksheet
    Dim wsBye As Worksheet
    Dim wsGreetings As Worksheet
    Dim lastRowData As Long
    Dim lastRowHello As Long
    Dim lastRowBye As Long
    Dim lastRowGreetings As Long
    Dim i As Long
    Dim sourceRow As Range
    Dim targetRange As Range
    
    ' 初始化工作表对象
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsHello = ThisWorkbook.Worksheets("Hello")
    Set wsBye = ThisWorkbook.Worksheets("Bye")
    Set wsGreetings = ThisWorkbook.Worksheets("Greetings")
    
    ' 关闭屏幕刷新提升效率
    Application.ScreenUpdating = False
    
    ' 获取Data表最后一行
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历Data表第2行到最后一行（跳过表头）
    For i = 2 To lastRowData
        Set sourceRow = wsData.Rows(i)
        
        ' 根据A列值判断目标工作表
        Select Case CStr(wsData.Cells(i, "A").Value)
            Case "Hello"
                ' 获取Hello表最后一行
                lastRowHello = wsHello.Cells(wsHello.Rows.Count, "A").End(xlUp).Row
                ' 若表为空，从第2行开始；否则从下一行开始
                If lastRowHello = 1 And wsHello.Cells(1, "A").Value = "" Then
                    lastRowHello = 1
                End If
                ' 复制非空白内容到目标位置
                sourceRow.SpecialCells(xlCellTypeConstants).Copy _
                    Destination:=wsHello.Cells(lastRowHello + 1, "A")
                    
            Case "Bye"
                lastRowBye = wsBye.Cells(wsBye.Rows.Count, "A").End(xlUp).Row
                If lastRowBye = 1 And wsBye.Cells(1, "A").Value = "" Then
                    lastRowBye = 1
                End If
                sourceRow.SpecialCells(xlCellTypeConstants).Copy _
                    Destination:=wsBye.Cells(lastRowBye + 1, "A")
                    
            Case "Greetings"
                lastRowGreetings = wsGreetings.Cells(wsGreetings.Rows.Count, "A").End(xlUp).Row
                If lastRowGreetings = 1 And wsGreetings.Cells(1, "A").Value = "" Then
                    lastRowGreetings = 1
                End If
                sourceRow.SpecialCells(xlCellTypeConstants).Copy _
                    Destination:=wsGreetings.Cells(lastRowGreetings + 1, "A")
        End Select
    Next i
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "数据复制完成"
End Sub

三个独立模块实现（分别处理每个类别） #

如果需要拆分功能，以下是三个独立的子过程：

1. 仅复制"Hello"行 #

Sub CopyHelloRows()
    Dim wsData As Worksheet
    Dim wsHello As Worksheet
    Dim lastRowData As Long
    Dim lastRowHello As Long
    Dim i As Long
    Dim sourceRow As Range
    
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsHello = ThisWorkbook.Worksheets("Hello")
    
    Application.ScreenUpdating = False
    
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    lastRowHello = wsHello.Cells(wsHello.Rows.Count, "A").End(xlUp).Row
    If lastRowHello = 1 And wsHello.Cells(1, "A").Value = "" Then lastRowHello = 1
    
    For i = 2 To lastRowData
        If CStr(wsData.Cells(i, "A").Value) = "Hello" Then
            Set sourceRow = wsData.Rows(i)
            sourceRow.SpecialCells(xlCellTypeConstants).Copy _
                Destination:=wsHello.Cells(lastRowHello + 1, "A")
            lastRowHello = lastRowHello + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Hello类数据复制完成"
End Sub

2. 仅复制"Bye"行 #

Sub CopyByeRows()
    Dim wsData As Worksheet
    Dim wsBye As Worksheet
    Dim lastRowData As Long
    Dim lastRowBye As Long
    Dim i As Long
    Dim sourceRow As Range
    
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsBye = ThisWorkbook.Worksheets("Bye")
    
    Application.ScreenUpdating = False
    
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    lastRowBye = wsBye.Cells(wsBye.Rows.Count, "A").End(xlUp).Row
    If lastRowBye = 1 And wsBye.Cells(1, "A").Value = "" Then lastRowBye = 1
    
    For i = 2 To lastRowData
        If CStr(wsData.Cells(i, "A").Value) = "Bye" Then
            Set sourceRow = wsData.Rows(i)
            sourceRow.SpecialCells(xlCellTypeConstants).Copy _
                Destination:=wsBye.Cells(lastRowBye + 1, "A")
            lastRowBye = lastRowBye + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Bye类数据复制完成"
End Sub

3. 仅复制"Greetings"行 #

Sub CopyGreetingsRows()
    Dim wsData As Worksheet
    Dim wsGreetings As Worksheet
    Dim lastRowData As Long
    Dim lastRowGreetings As Long
    Dim i As Long
    Dim sourceRow As Range
    
    Set wsData = ThisWorkbook.Worksheets("Data")
    Set wsGreetings = ThisWorkbook.Worksheets("Greetings")
    
    Application.ScreenUpdating = False
    
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    lastRowGreetings = wsGreetings.Cells(wsGreetings.Rows.Count, "A").End(xlUp).Row
    If lastRowGreetings = 1 And wsGreetings.Cells(1, "A").Value = "" Then lastRowGreetings = 1
    
    For i = 2 To lastRowData
        If CStr(wsData.Cells(i, "A").Value) = "Greetings" Then
            Set sourceRow = wsData.Rows(i)
            sourceRow.SpecialCells(xlCellTypeConstants).Copy _
                Destination:=wsGreetings.Cells(lastRowGreetings + 1, "A")
            lastRowGreetings = lastRowGreetings + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Greetings类数据复制完成"
End Sub

注意事项 #

• 确保工作簿中已存在Data、Hello、Bye、Greetings四个工作表
• 如果行中包含公式生成的内容，可将xlCellTypeConstants替换为xlCellTypeFormulas
• 运行前建议保存工作簿，避免意外数据丢失

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