Finding array data in worksheet values - vba

Question

I have a table sort of like this:
Pendergrass (606)-663-4567
Rich (606)-667-4567
Scott (606)-987-4567
Dennis (606)-233-4567
David (606)-888-4567
Red (606)-567-4567
Wendy (606)-765-4567
Todd (606)-677-4567
Andrea (606)-780-3451
Caroline (606)-992-7865
and the code I'm using looks like this:
Private Sub CommandButton2_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
'If ws.Name <> Worksheets("Report").Name Then
If ws.Name = "Sheet1" Then
With ws.Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
With Worksheets("Report")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = rFound.Value
End With
End If
Next a
End With
End If
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub
I would like if to take the numbers of David, Andrea and Caroline and put them any where in the Report page. This only grabs one.
Can anyone suggest where I am going wrong with this code?

Answer 1

Try the code below.
However, not sure why you are looping through all the sheets with For Each ws In ThisWorkbook.Worksheets , if at the following line you are checking If ws.Name = "Sheet1" Then.
You can replace the lines below (remove a For, a With and If) :
For Each ws In ThisWorkbook.Worksheets
With ws
'If ws.Name <> Worksheets("Report").Name Then
If .Name = "Sheet1" Then
With .Range("A1:E30").Cells
with a simple:
With Worksheets("Sheet1").Range("A1:E30").Cells
Code
Private Sub CommandButton2_Click()
Dim ws As Worksheet, bFound As Boolean, rFound As Range
Dim a As Long, aNames As Variant
aNames = Array("David", "Andrea", "Caroline")
For Each ws In ThisWorkbook.Worksheets
With ws
'If ws.Name <> Worksheets("Report").Name Then
If .Name = "Sheet1" Then
With .Range("A1:E30").Cells
For a = LBound(aNames) To UBound(aNames)
Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
If Not rFound Is Nothing Then
bFound = True
Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1) = rFound.Value
Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(, 1) = rFound.Offset(, 1).Value
End If
Next a
End With
End If
End With
Next ws
If Not bFound Then
MsgBox "None of the sheets contains the names " & Chr(10) & _
"'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
End If
End Sub