VBA search string and copy row - excel

Question

I am starting out with a table containing a name which corresponds to a job code and the start date of said job. See below:
The desired outcome of this is to almost flip it (it is becoming part of a bigger macro, must use VBA for this)
I need dates along the column headings, and the list of unique names. In the column will appear the job for that date. See below for an example:
I have been able to get the code to select all of the rows containing a persons name, however I can't workout how to one by one go through each of the selected rows, copy the job code and paste it to the new table under the correct corresponding date.
Since some jobs have multiple people this code uses InStr() to find occurances of the unqiue names
Sub NewTable()
Dim Rng As Range
Dim Cell As Object
Dim Found As Range
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Set Rng = Ws.Range("D:D")
searchString = "Emily"
For Each Cell In Rng
If InStr(Cell, searchString) > 0 Then
If Not Found Is Nothing Then
Set Found = Union(myUnion, Cell.EntireRow)
Else
Set Found = Cell.EntireRow
End If
End If
Next
If Found Is Nothing Then
MsgBox "The text was not found in the selection"
Else
Found.Select
End If
End Sub
Any help would be appreciated

Answer 1

Try this out:
Sub Tester()
Dim rw As Range, wsData As Worksheet, wsPivot As Worksheet, arr, e, r, c
Set wsData = ThisWorkbook.Worksheets("Input") 'sheet with original data
Set wsPivot = ThisWorkbook.Worksheets("Pivot") 'sheet for the final table
'loop over each row in the input table
For Each rw In wsData.Range("B6:E" & wsData.Cells(Rows.Count, "B").End(xlUp).Row).Rows
If Application.CountA(rw) = 3 Then 'row has data?
'try to match the date: add as new date if no match
c = Application.Match(CLng(rw.Cells(3).Value), wsPivot.Rows(1), 0)
If IsError(c) Then
c = wsPivot.Cells(1, Columns.Count).End(xlToLeft).Column + 1
If c < 4 Then c = 4 'dates start in D1
wsPivot.Cells(1, c).Value = rw.Cells(3).Value 'add the date
End If
arr = Split(rw.Cells(2).Value, ",") 'get array of all names
'check row for each name: add as new name if no match
For Each e In arr
'look for the name in Col B
r = Application.Match(Trim(e), wsPivot.Columns("B"), 0)
'if name not found, then add it in the next empty cell
If IsError(r) Then
r = wsPivot.Cells(Rows.Count, "B").End(xlUp).Row + 1
If r < 4 Then r = 4 'names begin in B4
wsPivot.Cells(r, "B").Value = e
End If
wsPivot.Cells(r, c).Value = rw.Cells(1).Value 'add the Job Code
Next e
End If
Next rw
End Sub