vba VBA循环工作表以查找单词的多个实例

VBA Looping Through Worksheet to find multiple instances of word

提问by teppuus

I am trying to write a macro for excelthat searches Sheet1and

我正在尝试为excel编写一个宏，用于搜索Sheet1和

• finds all instances of the words Forceand Grade, then
• copies the cells beneath those words (all cells to the first empty row), and pastes to Sheet2.

• 找到单词Force和Grade 的所有实例，然后
• 复制这些单词下方的单元格（所有单元格到第一个空行），并粘贴到Sheet2.

These words (Forceand Grade) can be found in any cell in Worksheet1 and the size of the used area changes every time the file is created.

这些词（Force和Grade）可以在 Worksheet1 的任何单元格中找到，并且每次创建文件时使用区域的大小都会发生变化。

So far, I can only get it to find the first instance of each word. I have tried many types of loops from examples on this website and others.

到目前为止，我只能让它找到每个单词的第一个实例。我从本网站和其他网站上的示例中尝试了多种类型的循环。

I feel like this should be simple, so I am not sure why I can't find the solution. I have tried a For Next Loop that starts with For i To ws.Columns.Count(with "ws" set to Sheet1), but it turns into an infinite loop (although the total column count was only around 15). Any help or nudge in the right direction would be appreciated.

我觉得这应该很简单，所以我不确定为什么我找不到解决方案。我尝试了一个以For i To ws.Columns.Count（“ws”设置为 Sheet1）开头的 For Next 循环，但它变成了一个无限循环（尽管总列数只有 15 左右）。任何帮助或朝着正确方向轻推将不胜感激。

Here is the code that works so far:

这是迄今为止有效的代码：

my code

我的代码

'COPY AND PASTE ALL FORCE VALUES TO FROM SHEET1 TO SHEET2
Sheets("Sheet1").Select
Cells.Find(What:=strSearch1, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Activate   'select cell below the word "Force"
Range(ActiveCell, ActiveCell.End(xlDown)).Select    'select all cells after "Force" to first empty cell
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Cells(Selection.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Select 'paste to next column
ActiveSheet.Paste

回答by brettdj

You should use FindNextto indentify all the matches. Something like this to copy all cells below all instances of Forceto column A of Sheet2

您应该使用FindNext来识别所有匹配项。像这样将所有Force实例下方的所有单元格复制到 Sheet2 的 A 列

Dim StrSearch As String
Dim rng1 As Range
Dim rng2 As Range

StrSearch = "Force"

With Worksheets(1).UsedRange
    Set rng1 = .Find(StrSearch, , xlValues, xlPart)
    If Not rng1 Is Nothing Then
        strAddress = rng1.Address
        Set rng2 = rng1
        Do
            Set rng1 = .FindNext(rng1)
            Set rng2 = Union(rng2, rng1)
        Loop While Not rng1 Is Nothing And rng1.Address <> strAddress
    End If
End With

If Not rng2 Is Nothing Then
For Each rng3 In rng2
Range(rng2.Offset(1, 0), rng3.End(xlDown)).Copy Sheets(2).Cells(Rows.Count, "A").End(xlUp)
Next
End If

回答by teppuus

With Worksheets(1).UsedRange

使用工作表(1).UsedRange

    'Code to copy and paste Force values
    Set rng1 = .Find(strSearch1, LookIn:=xlValues)
    SampleCnt = Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("A1:BJ2000"), "Grade")

    Do While i < SampleCnt
        rng1.Offset(1, 0).Activate   'select cell below the word "Force"
        Range(ActiveCell, ActiveCell.End(xlDown)).Select    'select all cells after "Force" to first empty cell
        numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
        Selection.Copy
        Sheets("Sheet2").Select
        Worksheets("Sheet2").Columns(Cnt).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
        Set rng1 = .FindNext(rng1)
        Cnt = Cnt + 2
        i = i + 1
    Loop

    'Code to copy and paste Grade values

    Cnt = 4
    i = 0
    Set rng2 = .Find(strSearch2, LookIn:=xlValues)

    Do While i < SampleCnt
        rng2.Offset(1, 0).Activate   'select cell below the word "Grade"
        Range(ActiveCell, ActiveCell.End(xlDown)).Select    'select all cells after "Grade" to first empty cell
        numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
        Selection.Copy
        Sheets("Sheet2").Select
        Worksheets("Sheet2").Columns(Cnt).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
        Set rng2 = .FindNext(rng2)
        Cnt = Cnt + 2
        i = i + 1
    Loop

End With