使用Excel VBA按特定条件复制指定项目代码的行至新工作表

以下是实现需求的VBA代码，附带关键逻辑说明：

Sub CopyProjectRows()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim searchCode As String
    Dim startRow As Long, endRow As Long, lastRow As Long
    Dim i As Long
    
    ' 替换为你的源数据工作表名称
    Set wsSource = ThisWorkbook.Worksheets("源数据")
    
    ' 获取要搜索的项目代码
    searchCode = InputBox("请输入要搜索的项目代码：")
    If searchCode = "" Then Exit Sub ' 取消输入则退出
    
    ' 创建并命名目标工作表
    Set wsTarget = ThisWorkbook.Worksheets.Add
    wsTarget.Name = "项目_" & searchCode
    
    ' 获取源表数据最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 定位目标项目的起始行
    startRow = 0
    For i = 1 To lastRow
        If wsSource.Cells(i, "A").Value = searchCode Then
            startRow = i
            Exit For
        End If
    Next i
    
    ' 未找到目标代码时的处理
    If startRow = 0 Then
        MsgBox "未找到项目代码：" & searchCode, vbExclamation
        Application.DisplayAlerts = False
        wsTarget.Delete ' 删除空表
        Application.DisplayAlerts = True
        Exit Sub
    End If
    
    ' 定位目标项目的结束行（下一个项目代码的前一行）
    endRow = lastRow
    For i = startRow + 1 To lastRow
        ' 这里假设A列非空单元格即为新项目代码，可根据实际格式调整判断条件
        ' 若项目代码是加粗格式，可改为：wsSource.Cells(i, "A").Font.Bold = True
        If wsSource.Cells(i, "A").Value <> "" Then
            endRow = i - 1
            Exit For
        End If
    Next i
    
    ' 复制目标行到新工作表
    wsSource.Rows(startRow & ":" & endRow).Copy Destination:=wsTarget.Rows(1)
    
    MsgBox "项目代码「" & searchCode & "」的行已复制完成！", vbInformation
End Sub

关键逻辑说明 #

1. 工作表配置：wsSource指定源数据所在工作表，需替换为你的实际表名；自动创建并命名目标工作表。
2. 代码输入：通过弹窗让用户输入要搜索的项目代码，取消输入则终止程序。
3. 起始行定位：遍历源表A列，找到第一个匹配目标代码的行号。
4. 结束行定位：从起始行下一行开始遍历，直到找到下一个项目代码（A列非空单元格），结束行设为该行的前一行；若到表尾无新项目，则结束行为源表最后一行。
5. 复制与清理：批量复制目标行到新表；若未找到目标代码，自动删除新建的空工作表避免冗余。

格式适配调整 #

如果你的项目代码是通过字体加粗等格式标识，可将结束行判断的条件替换为：

If wsSource.Cells(i, "A").Font.Bold = True Then

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