Sub FirstBeadType()
    Dim listRng As Range, cel As Range
    Dim i As Long, lr As Long
    
With Sheets("BeadTypes")
    Set listRng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With

With Sheets("Description")
    lr = .Range("D" & .Rows.Count).End(xlUp).Row
    For Each cel In listRng
        For i = 2 To lr
            If .Cells(i, "A") = "" And InStr(1, .Cells(i, "D"), cel.Value, vbTextCompare) > 0 Then
                .Cells(i, "A") = cel.Value
            End If
        Next i
    Next cel
End With
End Sub