Select and copy specific cells - excel

Question

I have an excel sheet that I want to select some cells based on their values then copy these cells to another sheet using VBA.
I have a chunk of code that go through all the excel sheetd and search for a specific value then return the total of this cells.
I need to copy right now just the cells in column H that have values "name" & "contact" and copy all these values to the sheet2 in the same workbook.
Then I to copy the cells that are next to the name and contact.
The end result is a new table that contain 2 columns name and contact and under each column the values of each name and contact that belong to it
Sample Data
Scan:
Private Sub CommandButton1_Click()
row_number = 4
count_of_str = 0
Do
DoEvents
row_number = row_number + 1
item_in_review = Sheets("Sheet1").Range("H" & row_number)
If InStr(item_in_review, "name") Then
count_of_str = count_of_str + 1
End If
Loop Until item_in_review = ""
MsgBox "the str occured: " & count_of_str & " times."
End Sub

Answer 1

Utilise the Find / FindNext methods
It's not entirely clear which columns your data is in. I have assumed the labels name and contact are in H, and the actual data in I
Also, I have assumed that every name will have a contact, and have not included any checks for that.
Sub Demo()
Dim row_number As Long, count_of_str As Long
Dim rToSearch As Range, rFound As Range, rng As Range
Dim strSearchTerm As String
Dim FirstAddr As String
Dim ws As Worksheet, rDest As Range
Dim cl As Range, ar As Range
strSearchTerm = "name"
With Sheets("Sheet1")
Set rToSearch = .Range(.Cells(5, 8), .Cells(.Rows.Count, 8).End(xlUp))
End With
Set rng = rToSearch.Find( _
What:=strSearchTerm, _
After:=rToSearch.Cells(rToSearch.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not rng Is Nothing Then
FirstAddr = rng.Address
Do
count_of_str = count_of_str + 1
If rFound Is Nothing Then
Set rFound = rng.Offset(0, 1)
Else
Set rFound = Union(rFound, rng.Offset(0, 1))
End If
Set rng = rToSearch.FindNext(rng)
Loop Until rng.Address = FirstAddr
End If
MsgBox "the str occured: " & count_of_str & " times."
' rFound now refers to all found cells
' Copy to somewhere
Set ws = Worksheets("YourDestinationSheet") '<~~Update as required
Set rDest = ws.Range("YourDestinationRange") '<~~Update as required
If Not rFound Is Nothing Then
rFound.Copy rDest '<~~ copy names
rFound.Offset(1, 0).Copy rDest.Offset(0, 1) '<~~ copy contacts
End If
' Process found cells
' eg
If Not rFound Is Nothing Then
For Each ar In rFound.Areas
For Each cl In ar.Cells
Debug.Print cl.Address
Next cl, ar
End If
End Sub

Answer 2

Untested:
Private Sub CommandButton1_Click()
Dim count_of_str As Long
Dim c as Range, d As Range
count_of_str = 0
Set c = Sheets("Sheet1").Range("H4") 'cell to check
Set d = Sheets("Sheet2").Range("A2") 'destination to copy to
Do While Len(c.Value) > 0
If InStr(c.Value, "name") > 0 Then
count_of_str = count_of_str + 1
c.Copy d
Set d = d.Offset(1, 0) 'next destination row
End If
Set c = c.Offset(1, 0) 'next cell to check
Loop
MsgBox "the str occured: " & count_of_str & " times."
End Sub