Copy Paste in another worksheet based on cell value vba

Hi, I'm new with VBA but did quite a bit of macros last week with the help from this forum. Now I'm stuck with this one and can't figure it out. Any help is much appreciated.

I have a schedule something like this on Sheet1:

Name Mon Tue Wed
John Surrey 0900-1700 Van 1230-1945 APH 0745-1515
Sue Surrey 0715-1600 APH 0900-1700 APH 0900-1700
Mike APH 0715-1600 APH 0900-1700 APH 0745-1515
Dan APH 0900-1700 Surrey 0715-1600

for each day of the week, shows the location and shift hours for each staff.
On Sheet2 = "Monday" I have the required shifts for each location on Mondays. something like this. I have 7 worksheets for 7 days of the week.
Mon Mon
APH 0715-1600 Surrey 0715-1600
APH 0900-1700 Surrey 0715-1600
APH 0900-1700 Surrey 0900-1700
APH 0745-1515 Surrey 0900-1700
Surrey 0800-1730

I need a macro to get the value of the first required shift for APH location (APH 0715-1600) and search in Sheet1 under Mon column, find the value, copy the corresponding staff name and paste it on Sheet "Monday" beside the first required shift on the left side cell. Then this repeats for the second required shift and so on. Then should go to the next location i.e. Surrey and starts with first required shift for Surrey (Surrey 0715-1600) and ...

The result should be like:

Mon Mon
Mike APH 0715-1600 Sue Surrey 0715-1600
Dan APH 0900-1700 Surrey 0715-1600
APH 0900-1700 John Surrey 0900-1700
APH 0745-1515 Surrey 0900-1700
Surrey 0800-1730


At the end I should know the required shifts that have no one assigned to and should be offered to staffs.

On Sheet1, not all staffs have an assigned shifts (some cells are blank). The cells are color coded by location.
On Sheet "Monday", there might be 2 or more of a same shift required.

Let me know if I need to provide more info.

Thanks in advance,

Can you post an example workbook please, with before and after? As you can probably see, the formatting of your examples isn't great.

Thank you walruseggman!

I have attached a sample worksheet. On tab "Monday" shows the before and after version. Your help is much appreciated.

This is incredible walruseggman I'm so amazed! Thank you so much.

It worked great. there are just a couple of issues.
1) can you please add a code at the beginning to remove all the names from worksheets "Monday", "Tuesday",..... like a clean start.
2) if "RN Schedule" has blank, like D7 is blank, then the code doesn't work. it finds the first blank cell in worksheet "Tuesday" which is B2 and pastes Dan into it.
3) if "RN Schedule" has more staff than needed scheduled for a shift, then the code doesn't work. it remains in an infinite loop. for example, on Wednesday, both John and Mike are scheduled for APH0745-1515 but on "Wednesday" tab we only have one shift of APH0745-1515 required. In this case it keeps going to "Loop Until Not c Is Nothing And c.Address <> FirstAdd" line. Is it possible to program it so after 10 tries, it paste a message like "You are overbooked for APH0745-1515 shift. Mike is also booked for APH0745-1515" at the bottom of the page.

Mr. walruseggman, please help me to get this code working. I'm having such a hard time finding solutions for those 3 issues. My deadline is coming up. I know it's a piece of cake for you. Please help me. I will thank you for ever.

Try this. Please remember that the days of the week on the RN Schedule and the tab names need to be the same.

Sub Penny110()
Dim ws As Worksheet
Set ws1 = Worksheets("RN Schedule")

LastRow = ws1.Cells(Rows.Count, "B").End(xlUp).Row

'clear names off the sheets
For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "RN Schedule" Then
        For k = 1 To 7 Step 3
            ws.Range(ws.Cells(4, k), ws.Cells(ws.Cells(Rows.Count, k).End(xlUp).Row, k)).ClearContents
        Next
    End If
Next


For i = 3 To 9
    Set ws2 = Worksheets(ws1.Cells(3, i).Value)
    For j = 4 To LastRow
        TheNames = ""
        FullShift = True
        With ws2.Range("A:H")
        SearchFor = RTrim(ws1.Cells(j, i).Value)
        If SearchFor <> "" Then
            Set c = .Find(SearchFor)
            If Not c Is Nothing Then
                If c.Offset(0, -1).Value = "" Then
                    c.Offset(0, -1).Value = ws1.Cells(j, 2).Value
                    FullShift = False
                Else
                    TheNames = TheNames & c.Offset(0, -1).Value & Chr(10)
                    FirstAdd = c.Address
                    Do
                    Set c = .FindNext(c)
                    If Not c Is Nothing Then
                        If c.Offset(0, -1).Value = "" Then
                            c.Offset(0, -1).Value = ws1.Cells(j, 2).Value
                            FullShift = False: Exit Do
                        Else
                            TheNames = TheNames & c.Offset(0, -1).Value & Chr(10)
                        End If
                    End If
                    Loop Until Not c Is Nothing And c.Address <> FirstAdd
                End If
            End If
            If FullShift = True Then
                ws2.Range("E" & Cells(Rows.Count, "E").End(xlUp).Row + 2).Value = _
                        "You are overbooked for " & SearchFor & " shift." & Chr(10) _
                        & "The following people are all booked for that shift:" & Chr(10) _
                        & TheNames & ws1.Cells(j, 2).Value
            End If
        End If
        End With
        
    Next
Next

End Sub