VBA循环提取指定文本区间行至新建工作表求助

嘿，作为VBA新手能写出初始代码已经超棒啦！我来帮你完善循环逻辑，实现你需要的完整功能。咱们先理清楚核心思路，再上完整代码：

核心思路 #

1. 收集所有匹配行：先把Full History File工作表A列里所有包含BLAST DRIVER ON的单元格位置都找出来，存到一个集合里，这样能清晰看到所有匹配行的顺序。
2. 循环处理相邻匹配对：遍历这个集合，每一对相邻的匹配行之间的所有行，复制到新建的工作表，工作表按顺序命名为Blasted 1、Blasted 2...
3. 边界情况处理：如果没有匹配行、只有1个匹配行，代码会给出提示，避免报错。

完整代码 #

Sub CopyBlastData()
    Dim wsSource As Worksheet
    Dim matchCells As Collection
    Dim cell As Range
    Dim firstMatch As String
    Dim i As Long
    Dim wsNew As Worksheet
    
    ' 初始化源工作表
    Set wsSource = ThisWorkbook.Sheets("Full History File")
    Set matchCells = New Collection
    
    ' 第一步：收集所有包含"BLAST DRIVER ON"的单元格
    With wsSource.Range("A:A")
        Set cell = .Find(What:="BLAST DRIVER ON", LookIn:=xlValues, LookAt:=xlWhole)
        If Not cell Is Nothing Then
            firstMatch = cell.Address ' 记录第一个匹配的地址，避免无限循环
            Do
                matchCells.Add cell ' 把匹配单元格加入集合
                Set cell = .FindNext(cell) ' 找下一个匹配
            Loop While Not cell Is Nothing And cell.Address <> firstMatch
        End If
    End With
    
    ' 检查是否有足够的匹配行
    If matchCells.Count = 0 Then
        MsgBox "没有找到任何包含'BLAST DRIVER ON'的行！"
        Exit Sub
    ElseIf matchCells.Count = 1 Then
        MsgBox "只找到1个包含'BLAST DRIVER ON'的行，无法提取中间数据！"
        Exit Sub
    End If
    
    ' 第二步：循环处理每一对相邻匹配行
    For i = 1 To matchCells.Count - 1
        ' 新建工作表并命名
        Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsNew.Name = "Blasted " & i
        
        ' 复制两个匹配行之间的所有行（注意：这里用Copy而不是Cut，避免源数据丢失，需要Cut的话可以改成Cut）
        wsSource.Range(matchCells(i).Offset(1, 0), matchCells(i + 1).Offset(-1, 0)).EntireRow.Copy _
            Destination:=wsNew.Range("A1")
    Next i
    
    MsgBox "数据提取完成！共创建" & matchCells.Count - 1 & "个工作表。"
End Sub

关键代码解释 #

• 收集匹配行：用Find和FindNext组合，配合Do...Loop循环，把所有匹配的单元格存入Collection集合，这样能按顺序保存所有匹配行的位置。
• 新建工作表：每次循环都在最后新建工作表，命名为Blasted 1、Blasted 2...，避免手动创建的麻烦。
• 复制数据：用Offset(1,0)和Offset(-1,0)来取两个匹配行之间的内容（不包含匹配行本身，如果你需要包含匹配行，可以去掉这两个Offset）。这里用Copy而不是Cut，避免源数据丢失，如果你确实需要剪切，可以把Copy改成Cut。
• 错误提示：处理了没有匹配行和只有1个匹配行的情况，避免代码报错，同时给用户明确提示。

注意事项 #

• 如果你的Full History File工作表A列有空白单元格，代码会自动停止查找吗？不会，因为Find会忽略空白单元格，直到遍历完整个A列。如果需要在遇到空白单元格时停止查找，可以在Do...Loop里加一个判断：If cell.Offset(1,0).Value = "" Then Exit Loop，不过需要根据你的实际数据调整。
• 如果已经存在Blasted 1等工作表，代码会报错，你可以在新建工作表前检查是否存在，或者先删除旧的工作表（谨慎操作）。

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