Excel - create vba macro - find cell containing certain word copy cell content paste to another worksheet

I would like to search an excel file for a certain word -> for each cell found -> copy that cell's content and paste it in another worksheet.
-> Make a list of the extracted content. (that is 2nd copy and paste will be placed below the 1st extracted cell).

Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Hi zaza,

First off, take a look at http://vbaexpress.com/kb/getarticle.php?kb_id=195 a useful find routine made by mdmackillop (also on EE occasionally), should probably do exactly as you need.

You can also use the following:

Sub zaza5586()
 Dim WS As Worksheet, nWS As Worksheet, vWhat As String, CLL As Range, FND As Range
 vWhat = InputBox("What are you searching for?")
 If Len(vWhat) = 0 Then Exit Sub
 Application.ScreenUpdating = False
 Set nWS = Sheets.Add
 On Error Resume Next
 nWS.Name = "Search Results"
 On Error GoTo 0
 For Each WS In ActiveWorkbook.Sheets
  If WS.Name <> nWS.Name Then
   Set FND = Nothing
   Set FND = FoundRange(WS.Cells, vWhat)
   If Not FND Is Nothing Then
    For Each CLL In FND.Cells
     With WS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
      .Value = CLL.Value
      .Offset(0, 1).Value = "'" & WS.Name & "'!" & CLL.Address(0, 0)
     End With
   End If
  End If
 Application.ScreenUpdating = True
End Sub
Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
 Dim FND As Range, FND1 As Range
 Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlPart)
 If Not FND Is Nothing Then
  Set FoundRange = FND
  Set FND1 = FND
  Set FND = vRG.FindNext(FND)
  Do Until FND.Address = FND1.Address
   Set FoundRange = Union(FoundRange, FND)
   Set FND = vRG.FindNext(FND)
 End If
End Function


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.