élaboration de paires

Bonjour Olivier et le forum,

Vicieux en diable ton pb mine de rien !... j'ai pas vu le temps passer et je vais manger seulement maintenant,

d'autant plus que près de la Méditerrannée il fait un beau soleil un peu frisquet quand même because Tramontane ;-)

ci joint une proposition

je vérifierai ma bidouille après la soupe
A+
Michel

re

petites modifs pour répondre à ta demande (1° occurence dans colonneA)

et limite du nombre maxi (256*255)

Michel

Bonjour Olivier,

Tu trouveras en pièce jointe un exemple qui, si je l'ai bien compris, devrait répondre au problème posé.

Il évalue en colonne A et B toutes les combinaisons possibles des cellules (Contigües) A1:An. Il supprime toutes les combinaisons équivalentes (Ex: 1,4 et 4,1), ainsi que tous les doublons (Ex: 4,1 et 4,1).

=====================================================
Private Sub CommandButton1_Click()
Dim InputRange, OutPutRange As Range
Dim Val As String

'Initialisation
Set InputRange = Range("A1:" & Range("A1").End(xlToRight).Address)

'Enumération des combinaisons
OutputRow = 2
For i = 1 To InputRange.Columns.Count
For j = 1 To InputRange.Columns.Count
If i <> j Then
Rows(OutputRow).Cells(1, 1) = InputRange.Cells(1, i).Value
Rows(OutputRow).Cells(1, 2) = InputRange.Cells(1, j).Value
OutputRow = OutputRow + 1
End If
Next j
Next i
Set OutPutRange = Range("A2:B" & OutputRow - 1)

'Arrangement des combinaisons pour détection des symétries
For Each Row In OutPutRange.Rows
If Row.Cells(1, 2) < Row.Cells(1, 1) Then
Val = Row.Cells(1, 1).Value
Row.Cells(1, 1).Value = Row.Cells(1, 2).Value
Row.Cells(1, 2).Value = Val
End If
Next Row

'Tri des combinaisons pour éliminer les combinaisons doubles
OutPutRange.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), _
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal

'Elimination des combinaisons doubles
For Each Row In OutPutRange.Rows
If Row.Cells(1, 1).Value = "" Then Exit For
If Row.Cells(1, 1).Value = Row.Offset(1, 0).Cells(1, 1).Value And _
Row.Cells(1, 2).Value = Row.Offset(1, 0).Cells(1, 2).Value Then
Rows(Row.Offset(1, 0).Row).Delete Shift:=xlUp
End If
Next Row

End Sub
=====================================================

Bon courage pour la suite ....

Omicron

Salut à vous,

Ma modeste contribution : solution par formules.

Si j'ai bien compris la question, il ne peut pas il y avoir de doublons (contrairement à la solution de Michel), c'est à dire que 3-2 est la même paire que 2-3.

J'ai testé avec du texte (colonnes cachées !) et cela m'a l'air de marcher (même pour les matchs en retour de compétition - lol).

Je n'ai pu tester la solution d'omicron, car j'ai un bug dans la macro.

Bon dimanche à vous.
Ândré.

Bonjour André, Olivier et le forum

Personnellement, je préfère souvent une solution par formule qu'une macro. donc si ce job était pour moi, j'aurais opté pour ta solution...

Pour moi 1,2 et 2,1 sont des paires différentes; pour reprendre ton exemple Monaco-Marseille, ce n'est pas pareil que Marseille-Monaco:demande à @Thierry pour confirmer!

En fait, la macro est + simple avec une seule combi et j'ai relu le post d'olivier: j'ai donc mis tout ça par groupe de 2 colonnes

Histoire de faire un coucou de remerciement a F. Sigonneau et Ti et puisque j'utilise une collection, j'ai ajouté un anti-doublon

ci dessous le patois:

-------------------

Option Explicit

Sub combiner()

Dim nbre As Long, cptr As Long, cptr2 As Long, col As Long
Dim source As Collection

Sheets(1).Activate
Application.ScreenUpdating = False

nbre = Application.CountA(Range("A:A"))

'collecte des données en éliminant les doublons
'd'après démos Fredéric Sigonneau et Ti
Set source = New Collection
On Error Resume Next
For cptr = 1 To nbre
source.Add Cells(cptr, 1).Value, CStr(Cells(cptr, 1).Value)
Next
On Error GoTo 0
nbre = source.Count

Sheets(2).Activate
col = 1
cptr = 1
For cptr = 1 To nbre - 1
Cells(1, col) = source(1)
source.Remove (1)
For cptr2 = 1 To source.Count
Cells(cptr2, col) = Cells(1, col)
Cells(cptr2, col + 1) = source(cptr2)
Next

col = col + 3

Next
End Sub
---------
Amicalement votre
Michel