基于匹配值复制行的Excel VBA宏开发及代码问题排查

我正在开发一个Excel VBA工具，需求如下：

• 在C2:N2区域定位标记为“X”的列
• 在该列的第4行到第10行（对应原描述的C4:C10范围，应为目标列的4-10行）查找三类条件：
  • Test：若位于列顶部（即该列第4行），将Sheet1的2:19行复制到新工作表C列的首个空行；若位于列底部（即该列第10行），复制Sheet2的2:19行至对应位置
  • Closed：依次将Sheet3、Sheet4的2:19行复制到新工作表
  • Open：依次将Sheet5、Sheet6的2:19行复制到新工作表
• 新工作表需按顺序编号（如Sheet_1、Sheet_2...）

已实现定位“X”列的代码，但跨工作表复制行的代码无法匹配需求正常运行，请求协助修复。

现有代码 #

定位“X”列的代码 #

Private Sub CommandButton1_Click()
    ' Dim FindString As String
    Dim Rng As Range
    FindString = "X"
    If Trim(FindString) <> "" Then
        With ActiveSheet.Range("C2:N2") ' 搜索C2到N2区域
            Set Rng = .Find(what:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            lookat:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True ' 定位到找到的X
            Else
                MsgBox "Nothing found" ' 未找到X
            End If
        End With
    End If
End Sub

无法正常运行的复制代码 #

Sub SearchForString()   
   Const ASearchRow = 2
   Const BSearchRow = 2
   Dim CopyToRow As Integer
   Dim rng1 As Range
   Dim rng2 As Range
   Dim cell As Range
   Dim found As Range
   
   ' Start copying data to row 2 in Sheet2 (row counter variable)
   CopyToRow = 2
   
   Set rng1 = Range(ActiveSheet.Cells(ASearchRow, 1), ActiveSheet.Cells(ASearchRow, 1).End(xlDown))
   Set rng2 = Range(ActiveSheet.Cells(BSearchRow, 2), ActiveSheet.Cells(BSearchRow, 2).End(xlDown))
   
   For Each cell In rng1
   
   Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
   
   If Not found Is Nothing Then
   
   cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & CopyToRow)
   
   CopyToRow = CopyToRow + 1
   
   End If
   
   Next cell

End Sub

现有复制代码存在以下核心问题：

1. 未关联定位到的“X”列，逻辑完全独立于定位代码，无法针对目标列的4-10行进行条件判断
2. 复制逻辑和需求不匹配，没有区分Test（顶部/底部）、Closed、Open三种不同的复制规则
3. 未实现新工作表的顺序编号创建逻辑

以下是整合定位、条件判断、复制及新工作表创建的完整代码，替换原有两个子程序：

Private Sub CommandButton1_Click()
    Dim targetCol As Range
    Dim checkRng As Range
    Dim cell As Range
    Dim newSheet As Worksheet
    Dim sheetNum As Integer
    Dim destStartRow As Long
    
    ' 1. 定位C2:N2中的X列
    Set targetCol = ActiveSheet.Range("C2:N2").Find(what:="X", _
                                                    LookIn:=xlValues, _
                                                    lookat:=xlWhole, _
                                                    MatchCase:=False)
                                                    
    If targetCol Is Nothing Then
        MsgBox "未找到标记为X的列"
        Exit Sub
    End If
    
    ' 2. 获取目标列的4-10行区域
    Set checkRng = ActiveSheet.Range(ActiveSheet.Cells(4, targetCol.Column), _
                                     ActiveSheet.Cells(10, targetCol.Column))
    
    ' 3. 创建按顺序编号的新工作表
    sheetNum = 1
    Do While True
        On Error Resume Next
        Set newSheet = ThisWorkbook.Worksheets("Sheet_" & sheetNum)
        On Error GoTo 0
        If newSheet Is Nothing Then
            Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            newSheet.Name = "Sheet_" & sheetNum
            Exit Do
        Else
            sheetNum = sheetNum + 1
        End If
    Loop
    
    ' 4. 遍历目标列的4-10行，处理不同条件的复制
    For Each cell In checkRng
        Select Case UCase(Trim(cell.Value))
            Case "TEST"
                ' 判断是否为顶部（第4行）或底部（第10行）
                If cell.Row = 4 Then
                    ' 复制Sheet1的2-19行到新工作表C列首个空行
                    destStartRow = newSheet.Cells(newSheet.Rows.Count, "C").End(xlUp).Row
                    If destStartRow = 1 Then destStartRow = 2 ' 若C列为空，从第2行开始
                    Sheet1.Rows("2:19").Copy Destination:=newSheet.Range("C" & destStartRow)
                ElseIf cell.Row = 10 Then
                    ' 复制Sheet2的2-19行到对应位置
                    Sheet2.Rows("2:19").Copy Destination:=newSheet.Range("C" & newSheet.Cells(newSheet.Rows.Count, "C").End(xlUp).Row + 1)
                End If
                
            Case "CLOSED"
                ' 依次复制Sheet3、Sheet4的2-19行
                destStartRow = newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row + 1
                Sheet3.Rows("2:19").Copy Destination:=newSheet.Range("A" & destStartRow)
                destStartRow = newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row + 1
                Sheet4.Rows("2:19").Copy Destination:=newSheet.Range("A" & destStartRow)
                
            Case "OPEN"
                ' 依次复制Sheet5、Sheet6的2-19行
                destStartRow = newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row + 1
                Sheet5.Rows("2:19").Copy Destination:=newSheet.Range("A" & destStartRow)
                destStartRow = newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row + 1
                Sheet6.Rows("2:19").Copy Destination:=newSheet.Range("A" & destStartRow)
        End Select
    Next cell
    
    MsgBox "新工作表已生成：" & newSheet.Name
End Sub

1. 定位逻辑优化：简化了Find方法的参数，保留核心必要参数，确保准确找到X列
2. 新工作表创建：通过循环检查工作表名称，确保创建的新工作表编号唯一（不会覆盖已存在的同名工作表）
3. 条件处理：
   • 用Select Case清晰区分三种条件，统一处理大小写（通过UCase避免大小写敏感问题）
   • 针对Test的顶部/底部判断，分别关联Sheet1和Sheet2的复制
   • 复制时通过End(xlUp).Row自动定位目标列的首个空行，避免硬编码行号导致的错误
4. 复制逻辑：明确指定复制的行范围和目标位置，确保跨工作表复制的准确性

内容的提问来源于stack exchange，提问作者CruzzerNpc-stack1202