Copy Column A data to Sheet 2 where rows matches Sheet 2 headers

I cannot find any code to finish my project and I would like some help. I can find lots of code to move data with matching headers on both sheets but my source has duplicate names in rows to match Sheet2 headers. I would like to do this with code since I have several others that I would run prior to this one. Thanks for your help.

I need to copy the data in Sheet1 ColumnA to Sheet2 Row2 where the Sheet1 Column B matches Sheet2 Row A header. The data amount will vary for names and departments. Column B will be sorted by department name prior to this code.

Below is Sheet1 data sample, Sheet2 with headers, and Sheet2 needed results.

MoveData.JPG

Assuming row 1 in sheet2 will be populated with the department names rather than need to determine the uniques from sheet1. Also assumed existence of header in sheet 1.

Sub SomeMacroName()
Dim ws1 As Worksheet:   Set ws1 = Sheets("sheet1")
Dim ws2 As Worksheet:   Set ws2 = Sheets("Sheet2")
Dim c As Range
Dim rng As Range

Application.ScreenUpdating = False

Set rng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, ws2.Cells(1, Columns.Count).End(xlToLeft).Column))

For Each c In rng
    If Len(c) > 0 Then
        With ws1
            .AutoFilterMode = False
            .Range("B1:B" & .Range("B" & Rows.Count).End(xlUp).Row).AutoFilter 1, c
            .Range("A2:A" & .Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy c.Offset(1)
            .AutoFilterMode = False
        End With
    End If
Next c

Application.ScreenUpdating = True

End Sub

Thanks for the reply. I tested the code on a copy of my data and it worked perfectly. Thanks for your help.