Microsoft 365 Cases à cocher et BDD / macro pour faire le lien

Sub Choix()
Dim F As Worksheet, dest As Range, o As Object, a$(), i%, ub%, r As Range, b$(), j&, liste
Set F = Sheets("Besoin Client")
Set dest = F.[C22] 'cellule des résultats, à adapter
For Each o In F.DrawingObjects
    If LCase(o.Name) Like "*option*" Then
        If o.Value = 1 Then
            ReDim Preserve a(i) 'base 0
            a(i) = o.Text
            i = i + 1
        End If
    End If
Next
ub = UBound(a)
For Each r In Sheets("BDD Papiers").[A1].CurrentRegion.Rows
    For i = 0 To ub
        If Application.CountIf(r, a(i)) = 0 Then GoTo 1
    Next i
    ReDim Preserve b(j) 'base 0
    b(j) = r.Cells(1)
    j = j + 1
1 Next r
With Sheets("Choix") 'feuille auxiliaire
    .[A1].CurrentRegion.Delete xlUp 'RAZ
    dest = "" 'RAZ
    If j Then
        '---transposition---
        ReDim liste(1 To UBound(b) + 1, 1 To 1)
        For j = 0 To UBound(b)
            liste(j + 1, 1) = b(j)
        Next j
        '---liste de validation---
        With .[A1].Resize(UBound(liste))
            .Value = liste
            .Name = "Liste"
        End With
        F.Visible = xlSheetVisible 'au cas où...
        dest = .[A1] '1er terme de la liste en C22
        Application.Goto dest
    End If
End With
End Sub

Sub Effacer()
Dim o As Object
For Each o In ActiveSheet.DrawingObjects
    If LCase(o.Name) Like "*option*" Then o.Value = xlOff
Next
Choix
End Sub

If i = 0 Then ReDim a(0): a(0) = Chr(1)

        dest.Validation.Add xlValidateList, Formula1:="=Liste"
        dest.Validation.InCellDropdown = UBound(b) 'affiche ou masque la flèche

Sub Choix()
Dim F As Worksheet, dest As Range, o As Object, a$(), i%, ub%, r As Range, b$(), j&, liste
Set F = Sheets("Besoin Client")
Set dest = F.[B22] '1ère cellule des résultats, à adapter
For Each o In F.DrawingObjects
    If LCase(o.Name) Like "*option*" Then
        If o.Value = xlOn Then
            ReDim Preserve a(i) 'base 0
            a(i) = o.Text
            i = i + 1
        End If
    End If
Next
If i = 0 Then ReDim a(0): a(0) = Chr(1)
ub = UBound(a)
For Each r In Sheets("BDD Papiers").[A1].CurrentRegion.Rows
    For i = 0 To ub
        If Application.CountIf(r, a(i)) = 0 Then GoTo 1
    Next i
    ReDim Preserve b(j) 'base 0
    b(j) = r.Cells(1)
    j = j + 1
1 Next r
'---restitution---
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
dest(1, 2).Resize(F.Rows.Count - dest.Row + 1, 4).HorizontalAlignment = xlCenterAcrossSelection 'centrage sur les colonnes C:F
dest.Resize(F.Rows.Count - dest.Row + 1, 2).ClearContents 'RAZ
If j Then
    ReDim liste(1 To 2 * UBound(b) + 1, 1 To 2)
    For j = 1 To UBound(liste) Step 2
        liste(j, 1) = "Choix " & (j + 1) / 2
        liste(j, 2) = b((j - 1) / 2)
    Next j
    dest.Resize(UBound(liste), 2) = liste
End If
End Sub