Search for text in excel sheet and extract range of cells to a table

Question

Regularly I have to extract some data from excel sheets. Most of the time the sheet is small enough to do this per hand, which means, looking for a specific string and manually copy-paste the cells of interest.

Example of an excel sheet

This time I have a file with more than 5000 lines, which prevents me to do this as usual. This is a good occasion to write a simple code to do that automatically. The best way to do this in my case would be to:

• 1) Look for the cells containing the term "text"
• 2) For each cell:
  • 2.1) Select a range of cells
  • 2.2) Copy the range of cells and paste it to this destination range

As I am not used to code, I search on internet some code with similar behaviour. What I found so far is a code for the 1) step. In the following code, the addresses of the cells are written in a destination range:

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

Regarding the step 2.1), I know that I have to implement this to select a range for each cell found in the step 1):

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

Finally, I planned to use the following code for the step 2.2):

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

Despite my efforts, I don´t know how to code that properly to make this code working. Could someone give me a little help?

Answer 1

Try this. You might need to adjust the destination range to suit.

Also check the Find parameters; in particular, are you looking for cells containing just the text entered in the input box or could cells contain other text (adjust lookat).

The Resize bit says copy a range of 5 rows by 10 columns where the top left cell is the one containing the found text.

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