passing values in an array to corresponding tabs

hi Mr. Excel, please help.

here are the facts:

***Range A1 to range A5 of "sheet1" lists the employee #. For example A1 equals 150, A3 equals 145, etc.

***Range B1 to range B5 of "sheet1" lists the names of the employee

***there 5 tabs next to "sheet1" which are named "Emp#150", "Emp#300", "Emp#145", "Emp#52",
"Emp#500"

***In each of the 5 tabs, there are two asterisks
(for example "**") in a single cell within the range of B1 to B20. Each tab has a unique location
of where the two asterisks are within B1 to B20.
For example, in tab "Emp#300", the asterisks could be in cell B11, and in tab "Emp#52", the asterisks could be in cell B8, etc.

Below is what i want to accomplish using VBA macro:

For each employee number listed in range A1 to A5,
I would like to copy the corresponding names listed in range B1 to B5 of "Sheet1" to the corresponding 5 tabs. For example, the employee name in cell B1 (which corresponds the the employee # in A1 whose value is 150) would be copied to tab "Emp#150". In addition,
I would also like the employee name to be copied in the next blank row after the two asterisks (**), which are uniquely located in range B1 to B20 in each of the 5 tabs.

I tried the following code, but still no luck.

Sub CopyEmpName()

Dim R$
Set Data = Sheets("Sheet1").Range("A1")
Records = Application.CountA(Sheets("Sheet1").Range("B1:B200")

For i = 1 to Records
EmpNo = Data.Offset(i - 1, 0).Value
EmpName = Data.Offset(i - 1, 2).Value

E$ = Str$(EmpNo)
E$ = Trim$(E$)

Sheets("Emp#" + E$).Select
ActiveSheet.Range("B1:B200").Select

For Each cell in Selection
If cell.Value = "**" Then
cell.Select
End If
Next cell

NextRow = ActiveCell.Row + ActiveCell.CurrentRegion.Rows.Count

Cells(NextRow, 2) = EmpName
Next i

End Sub