在 Excel 工作表中搜索文本并将单元格范围提取到表格中答案

【问题标题】：Search for text in excel sheet and extract range of cells to a table在 Excel 工作表中搜索文本并将单元格范围提取到表格中
【发布时间】：2020-03-07 23:40:12
【问题描述】：

我必须定期从 Excel 表中提取一些数据。大多数情况下，表格足够小，可以手动执行此操作，这意味着，查找特定字符串并手动复制粘贴感兴趣的单元格。

Example of an excel sheet

这次我有一个超过 5000 行的文件，这使我无法像往常一样执行此操作。这是编写简单代码自动执行此操作的好时机。就我而言，最好的方法是：

1) 查找包含“文本”一词的单元格
2) 对于每个单元格：
- 2.1) 选择单元格范围
- 2.2) 复制单元格区域并将其粘贴到此目标区域

由于我不习惯编码，我在互联网上搜索了一些具有类似行为的代码。到目前为止，我发现的是 1) 步骤的代码。在以下代码中，单元格的地址写入目标范围：

Dim findWhat As String, address As String
Dim fsr As Range, rs As Range, fCount As Long

findWhat = InputBox("Enter what you want to find?", "Find what...")

If Len(findWhat) > 0 Then
    'clearFinds
    Set frs = Range("A1:AW6000")
    Set rs = frs.Find(What:=findWhat)
    If Not rs Is Nothing Then
        address = rs.address
        Do
            Range("bb1").Offset(fCount).Value = rs.Value
            Range("bc1").Offset(fCount).Value = rs.address
            Set rs = frs.FindNext(rs)
            fCount = fCount + 1
        Loop While Not rs Is Nothing And rs.address <> address
    End If
End If

关于步骤 2.1)，我知道我必须实现这一点，以便为步骤 1) 中找到的每个单元格选择一个范围：

Range(ActiveCell, ActiveCell.Offset(4, 9))

最后，我计划在步骤 2.2) 中使用以下代码：

Worksheets("Sheet1").Range("A1:D4").Copy _ 
    destination:=Worksheets("Sheet2").Range("E5")

尽管我很努力，但我不知道如何正确编码以使该代码正常工作。有人能给我一点帮助吗？

【问题讨论】：

您是否在某个列中寻找您的特定值？还是所有列？
如果我是正确的，您想找到某个单词，然后从该单词开始将所有内容向下复制 4 个单元格，向右复制 9 个单元格到另一张纸上。对找到的每个单词都这样做吗？您只需要这些单元格中的文本，还是所有格式等？
@JvdV 我正在寻找所有列中的特定文本
@Plutian 我不需要为找到的每个单词创建另一个工作表，而是一个“全局”目标范围，如目标表
好吧，在这种情况下，您的FindNext 方法看起来还不错。现在与步骤 2.1 中的 ActiveCell 的区别在于 Find 实际上设置了一个 Range 对象。在你的情况下rs。所以尝试使用Offset从那里开始工作。

标签： excel vba range copy-paste

【解决方案1】：

试试这个。您可能需要调整目标范围以适应。

还要检查Find参数；特别是，您是在寻找仅包含在输入框中输入的文本的单元格还是包含其他文本的单元格（调整lookat）。

Resize 位表示复制 5 行 x 10 列的范围，其中左上角的单元格是包含找到的文本的单元格。

Sub x()

Dim findWhat As String, s As String
Dim rs As Range, frs as Range

findWhat = InputBox("Enter what you want to find?", "Find what...")

If Len(findWhat) > 0 Then
    'clearFinds
    Set frs = Worksheets("Sheet1").Range("A1:AW6000")
    Set rs = frs.Find(What:=findWhat, Lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
    If Not rs Is Nothing Then
        s = rs.address
        Do
            Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp)(2).Resize(5, 10).Value = rs.Resize(5, 10).Value
            Set rs = frs.FindNext(rs)
        Loop While rs.address <> s
    End If
End If

End Sub

【讨论】：