[XL-2010] Macro excel VBA combinaisons liste sans doublon

Macro excel VBA combinaisons liste sans doublon

Bonjour
J'ai une liste de valeurs contenues dans une colonne A (val1,val,2,...,valn)
Je souhaite combiner l'ensemble de ces valeurs dans les colonnes B et C de telle sorte à obtenir :

Colonne B Colonne C

Val1 Val1

Val1 Val2

...

Val1 Valn

Val2 Val2

Val2 Val3

...

Val2 Valn

...

Valn Valn

Attention je ne souhaite pas prendre en compte la combinaison Valy, Valx si Valx, Valy existe déjà.

Est-ce que qu'un a une petite idée Du code VBA que je pourrais utiliser.

Merci pour votre aide.

Colonne B	Colonne C
Val1	Val1
Val1	Val2
...
Val1	Valn
Val2	Val2
Val2	Val3
...
Val2	Valn
...
Valn	Valn

Bonjour,

Pas sûr d'avoir bien compris mais testes ce code pour voir si le résultat convient :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
Sub Test()
 
    Dim Plage As Range
    Dim Cel As Range
    Dim I As Long
    Dim J As Long
 
    With Worksheets("Feuil1"): Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
 
    For Each Cel In Plage
 
        For I = Cel.Row To Plage.Count
 
            J = J + 1: Cells(J, 2).Value = Cel.Value: Cells(J, 3).Value = Cells(I, 1).Value
 
        Next I
 
    Next Cel
 
End Sub

Bonjour,

Une autre solution, utilisant les dictionnaires :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Option Explicit
 
Sub CartesianProduct()
    Const lngFIRSTROW = 1                       'Valeur à modifier selon la première ligne contenant les valeurs à combiner
    Dim lngLastRow As Long                      'Dernière ligne de la plage de données
    Dim strCellValue As String                  'Valeur de la cellule parcourue
    Dim objBufferDictionary As Object           'SCRIPTING.DICTIONARY - Comprend la liste sans doublons des valeurs contenues dans la première colonne
    Dim objResultDictionary As Object           'SCRIPTING.DICTIONARY - Comprend l'ensemble des combinaisons des valeurs uniques de la première colonne avec elle-même
    Dim strBufferValue_1 As String              'Permet de stocker temporairement une combinaison (dans l'ordre A-B)
    Dim strBufferValue_2 As String              'Permet de stocker temporairement une combinaison (dans l'ordre B-A)
    Dim strRecordSeparator As String            'Permet de séparer les deux valeurs de la combinaison dans
    Dim xlCurrentCalculation As XlCalculation   'Stocke le mode de calcul actif
    Dim strBufferArray() As String              'Tableau de deux valeurs dans lequel on stocke les deux éléments constituant une combinaison
    Dim i As Long                               'Itérateur de boucle
    Dim j As Long                               'Itérateur de boucle
 
 
    With ActiveSheet
        'Le bloc de code suivant permet d'extraire toutes les valeurs uniques de la première colonne, qui sont stockées dans le dictionnaire objBufferDictionary
        lngLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
        Set objBufferDictionary = CreateObject("SCRIPTING.DICTIONARY")
        For i = lngFIRSTROW To lngLastRow
            strCellValue = CStr(.Cells(i, 1))
            If Not objBufferDictionary.Exists(strCellValue) Then
                objBufferDictionary.Add strCellValue, strCellValue
            End If
        Next i
 
        'Le bloc de code suivant génère les combinaisons uniques de valeurs de l'objet objBufferDictionary avec lui-même. Les résultats sont ensuite stockés dans l'objet objResultDictionary
        Set objResultDictionary = CreateObject("SCRIPTING.DICTIONARY")
        strRecordSeparator = Chr(30)
        For i = 0 To objBufferDictionary.Count - 1
             For j = 0 To objBufferDictionary.Count - 1
                'NB : On évalue les combinaisons dans les deux sens. Par exemple, si on a déjà la combinaison A-B, on ne stocke pas la combinaison B-A
                strBufferValue_1 = objBufferDictionary.items()(i) & strRecordSeparator & objBufferDictionary.items()(j)
                strBufferValue_2 = objBufferDictionary.items()(j) & strRecordSeparator & objBufferDictionary.items()(i)
                If Not objResultDictionary.Exists(strBufferValue_1) And Not objResultDictionary.Exists(strBufferValue_2) Then
                    objResultDictionary.Add strBufferValue_1, strBufferValue_1
                End If
             Next j
        Next i
        Set objBufferDictionary = Nothing
 
        'Enfin, on restitue le résultat sur la feuille de calcul : les combinaisons uniques sont scindées de manière à récupérer les deux valeurs les constituant et sont inscrites sur l'onglet actif
        xlCurrentCalculation = Application.Calculation
        Application.Calculation = xlCalculationManual
        For i = 0 To objResultDictionary.Count - 1
            strBufferArray = Split(objResultDictionary.items()(i), strRecordSeparator)
            .Cells(i + 1, 2) = strBufferArray(0)
            .Cells(i + 1, 3) = strBufferArray(1)
        Next i
        Set objResultDictionary = Nothing
        Application.Calculation = xlCurrentCalculation
    End With
End Sub

Merci beaucoup.
Ton code fonctionne parfaitement et répond exactement à mon besoin.
Merci encore pour ton aide.

Re,

Lequel de code ? car le résultat est légèrement différent !

Ton code Theze me donne le résultat que j'attendais.
Merci encore pour ton aide.

Merci également Mr poulpe.

Bonjour,

Merci de ta réponse, j'avais donc bien compris la demande :D