Macro : Trouver les combinaisons de valeurs d'une liste donnant la même somme

Dim objResultats As Object ' Dictionnaire pour stocker les combinaisons uniques

Sub TrouverCombinations()
    ' Objectif    : Trouver les combinaisons de valeurs dont la somme est égale à une valeurs cible.
    ' Utilisation : Sélectionner la plage des valeurs et lancer la macro.
    ' Retour      : Une liste de combinaisons dans une nouvelle feuille.
    ' Auteur      : Arnaud (www.1forme.fr).
    ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les
    '               même conditions, seulement à titre personnel et citant l'auteur/site d'origine.
    Dim vaValeurs   As Variant
    Dim vaCible     As Variant
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Sélectionner la plage des valeurs", vbCritical, "Exécution impossible !"
        Exit Sub
    End If
    If Selection.Cells.Count < 3 Then
        MsgBox "Sélectionner une plage de plus de 2 cellules", vbCritical, "Exécution inutile !"
        Exit Sub
    End If
    vaCible = InputBox("Valeur à atteindre ?", "valeur Cible")
    If Not IsNumeric(vaCible) Then
        MsgBox "Valeur à atteindre incorrecte ", vbCritical, "Exécution impossible !"
        Exit Sub
    End If
    vaValeurs = Application.Transpose(Selection.Value)  ' Tab 1D grace au transpose
    vaValeurs = FiltreValeurs(Selection)
    Set objResultats = CreateObject("Scripting.Dictionary")
    
    RechercherCombinations vaValeurs, vaCible, 1, 0, "" ' Lancer la recherche des combinaisons
    
    If objResultats.Count > 0 Then ' Afficher les résultats
        Dim Cle     As Variant
        Dim strRes  As Variant
        Dim i       As Integer, j       As Integer
        
        Worksheets.Add
        i = 2
        Cells(1, 2) = "Combinaisons"

        For Each Cle In objResultats.Keys
            Cells(i, 1) = "c" & i - 1
            strRes = Split(Mid(Cle, 1, Len(Cle) - 1), ";")
            For j = 0 To UBound(strRes)
                Cells(i, j + 2) = CDbl(strRes(j))
            Next
            i = i + 1
        Next
    Else
        MsgBox "Pas de combinaison trouvée", vbInformation, "Résultats"
    End If
End Sub

Sub RechercherCombinations(vaValeurs As Variant, vaCible As Variant, intIndex As Integer, dblSommeActuelle As Double, strCombinaison As String)
    ' Procédure récursive basé sur la technique du backtracking
    Dim i                       As Integer
    Dim dbNouvelleSomme         As Double
    Dim strNouvelleCombinaison  As String
    
    If dblSommeActuelle = vaCible Then ' Enregistrer la strCombinaison unique dans le dictionnaire
        If Not objResultats.exists(strCombinaison) Then objResultats.Add strCombinaison, True
        Exit Sub
    End If
    
    For i = intIndex To UBound(vaValeurs)    ' Boucle sur les vaValeurs restantes
        dbNouvelleSomme = dblSommeActuelle + vaValeurs(i)
        ' Construire la nouvelle strCombinaison triée pour éviter les doublons
        strNouvelleCombinaison = Trim(strCombinaison & vaValeurs(i) & ";")
        ' Appel récursif avec la nouvelle somme et la nouvelle strCombinaison
        RechercherCombinations vaValeurs, vaCible, i + 1, dbNouvelleSomme, strNouvelleCombinaison
    Next
End Sub

Function FiltreValeurs(rgPlage As Range) As Variant
    ' Objectif    : Élimination des valeurs non numériques et vides de la plage de valeurs
    Dim vaValeurs   As Variant
    Dim j           As Long
    
    j = 1
    vaValeurs = Application.Transpose(rgPlage.Columns(1)) ' Tab 1D d'indice 1
    For i = 1 To UBound(vaValeurs)
        If IsNumeric(vaValeurs(i)) And vaValeurs(i) <> "" Then
            vaValeurs(j) = vaValeurs(i)
            j = j + 1
        End If
    Next
    ReDim Preserve vaValeurs(LBound(vaValeurs) To j - 1)
    FiltreValeurs = vaValeurs
End Function