Search/copy/paste

QuestionEdit

I was trying to search for a word(s) in a certain column. Lets say in column H and the words would be dog, cat, horse, cow. There are about 40,000 lines of info and there are blank rows in between intermittently. I actually have about 30 different words but I'm sure I could add more words if you can show me the 4 mentioned above. When it finds theit will copy the row and paste the row into another worksheet.

Thanks for your help, Dan

AnswerEdit

Dan,

Sub GetData() Dim col As Long Dim sh As Worksheet Dim sh1 As Worksheet Dim sAddr As String, s As Variant Dim rng As Range, rng1 As Range Dim rr As Range, ar As Variant Dim i As Long ' destination sheet Set sh1 = Worksheets("Sheet2") ' sheet to search Set sh = Worksheets("Sheet1") ' column to search col = 5 ' in a certain column ar = Array("dog", "cat", "horse", "cow") Set rr = sh.Range(sh.Cells(1, col), _

sh.Cells(Rows.Count, col).End(xlUp))

For i = LBound(ar) To UBound(ar)

 s = ar(i)
 Set rng1 = Nothing

 Set rng = rr.Find(What:=s, _
   After:=rr(rr.Count), _
   LookIn:=xlFormulas, _
   LookAt:=xlPart, _
   SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, _
   MatchCase:=False)

If Not rng Is Nothing Then

 sAddr = rng.Address
 Do
   If rng1 Is Nothing Then
      Set rng1 = rng
   Else
      Set rng1 = Union(rng1, rng)
   End If
   Set rng = rr.FindNext(rng)
 Loop Until rng.Address = sAddr
 If Not rng1 Is Nothing Then
    rng1.EntireRow.Copy sh1.Cells(Rows.Count, col _
       ).End(xlUp)(2).Offset(0, -(col - 1))
 End If

End If Next End Sub

worked for me. Change col to refer to the column you want to search. Add words to the array if you want. change Sheet1 and Sheet2 to the names of the sheets you will actually use.

as set up, it looks for theas a substring. So it would pick up the row if just thewere in a cell in the column or if it was part of a larger string in a cell the column.