List of Required Positions Auto-Filled with Matching List without Duplicating

[jamiers]

Hi All,

I have a strange request. I have attached this workbook of sample data.
qualnames.xlsx

Sheet 1 has a list of required positions.
Sheet 2 has a list of all the people that are qualified for a position listed on Sheet 1.

How can I have Excel fill names into sheet 1 column B from Sheet 2 if they match the required position.... AND the big one... don't duplicate the name anywhere on Sheet 1?

 

[jamiers]

sorry -- just noticing that the link above isn't working:
qualnames.xlsx

 

[mumps]

See if this does what you want.

Sub FillPositions()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, v1 As Variant, i As Long, fnd As Range, sAddr As String
    Set srcWS = Sheets("She")
    Set desWS = Sheets("Sheet1")
    v = desWS.Range("A2", desWS.Range("A" & Rows.Count).End(xlUp)).Value
    For i = LBound(v) To UBound(v)
        Set fnd = srcWS.Range("B:B").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                If fnd.Offset(, 1) <> "x" And WorksheetFunction.CountIf(desWS.Range("B:B"), fnd.Offset(, -1)) = 0 Then
                    desWS.Range("B" & i + 1) = fnd.Offset(, -1)
                    fnd.Offset(, 1) = "x"
                    Exit Do
                Else
                    Set fnd = srcWS.Range("B:B").FindNext(fnd)
                    If fnd.Offset(, 1) <> "x" And WorksheetFunction.CountIf(desWS.Range("B:B"), fnd.Offset(, -1)) = 0 Then
                        desWS.Range("B" & i + 1) = fnd.Offset(, -1)
                        fnd.Offset(, 1) = "x"
                        Exit Do
                    End If
                End If
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
    Next i
    srcWS.Columns("C:C").ClearContents
    Application.ScreenUpdating = True
End Sub