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?
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

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.