Home » excel » excel – VBA Looping Through Worksheet to find multiple instances of word

excel – VBA Looping Through Worksheet to find multiple instances of word

Posted by: admin April 23, 2020 Leave a comment

Questions:

I am trying to write a macro for that searches Sheet1 and

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

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

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.

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
How to&Answers:

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

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

Answer:

With Worksheets(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