Replace Input box with Project Array
 

I have code that works as expected with an input box. I would like the
input box replaced with the array of projects, which are defined in
column "A" of the active sheet starting at Row 5. The projects are
defined by the left (6) characters in "A". Need help. TIA

For example column data:

05-001-000-000-000
06-001-000-000-000 etc.

Projects are 05-001 and 06-001. The code:

Sub Copy340WIP()
Dim WBwip As Workbook
Dim WB2 As Workbook

Set WB2 = ActiveWorkbook

On Error Resume Next
Set WBwip = Workbooks("RF 340-000.xls")
On Error GoTo 0
If WBwip Is Nothing Then
ChDir "S:\FIN\Finance\Capital Projects\WIP Detail"
Workbooks.Open filename:= _
"S:\FIN\Finance\Capital Projects\WIP Detail\RF 340-000.xls"
Else
'already open
End If

WBwip.Sheets("340-000-900 Pivot Table").Activate

Call FindStr("Proj")

Selection.ShowDetail = True

ActiveSheet.Move After:=WB2.Worksheets(WB2.Worksheets.Count)

Application.DisplayAlerts = True

End Sub

Function FindStr(FindProj As String) As String
Dim frng As Range

FindProj = InputBox("Enter Project Number, such as 00-000", "Enter
Project Number", "06-012") <<<<<<<REPLACE THIS WITH PROJECT ARRAY

Set frng = Cells.Find(what:=FindProj, LookIn:=xlFormulas,
lookat:=xlPart)
If Not frng Is Nothing Then
FindStr = frng.Offset(0, 9).Address(1, 1, xlA1)
Else
MsgBox ("Proj, not found")
End If
frng.Offset(0, 9).Activate

End Function

Greg