Collect all the found cells then paste at one go.
Sub copy_found_Cells()
Dim Cell As Range, tempR As Range, rangeToCheck As Range
'check each cell in the selection
findall = InputBox("Enter a search word")
For Each Cell In Selection
If Cell.Value = findall Then
If tempR Is Nothing Then
'initialize tempR with the first qualifying cell
Set tempR = Cell
Else
'add additional cells to tempR
Set tempR = Union(tempR, Cell)
End If
End If
Next Cell
'display message and stop if no cells found
If tempR Is Nothing Then
MsgBox "There are no cells found " & _
"in the selected range."
End
End If
'select qualifying cells
tempR.Copy Destination:=Sheets("Sheet2").Range("A1")
End Sub
Gord Dibben MS Excel MVP