Discussion :

[frederic89]

Bonjour à tous,
J'essaie d'aider ma fille sur un boulot qu'elle doit faire. Cette tache demande énormément de temps et le risque d'erreur est grand. Son besoin n'est pas simple à expliquer. j'ai fait une feuille XL dans laquelle j'explique son besoin. l’objectif est de pouvoir automatiser cette tache.
Merci d'avance,
Salutations

[parmi]

Bonjour,

Si j'ai bien compris, je commencerais par un tri et j'irais comme suit en spécifiant le nom des feuilles (et classeurs si nécessaire):

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
    Dim I As Long, J As Long, nbLignes As Long, LigneDest As Long
    Dim Cas As String
 
    'Tri des données par CAS et Ordre
    nbLignes = Cells(Rows.Count, "A").End(xlUp).Row
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A2:A" & nbLignes) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C2:C" & nbLignes) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A1:C" & nbLignes)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'Copie dans la feuille Feuil2
    LigneDest = 1
    For I = 2 To nbLignes - 1       'on laisse tomber la dernière ligne
        Cas = Range("A" & I)
        For J = I + 1 To nbLignes   'ici on conserve la dernière
            If Range("A" & J) = Cas Then
                LigneDest = LigneDest + 1
                Sheets("Feuil2").Range("A" & LigneDest) = Cas
                Sheets("Feuil2").Range("B" & LigneDest) = Range("B" & I) & " " & Range("B" & J)
            Else
                Exit For
            End If
        Next
    Next

[frederic89]

Un grand MERCI à "parmi " qui à résolu mon problème en une trentaine de lignes..... j'en reste sur le ...
Merci

[parmi]

J'ai besoin d'une variante. En gros j'ai besoin aussi d'avoir les doublon. Dans mon exemple XL dans la cas 1, j'ai le duo Rouge Vert (suite a votre programme) mais maintenant je souhaite aussi avoir le duo Vert Rouge. Pour faire plus simple par CAS avoir l'ensemble des combinaison possible. Est ce possible?
Merci d'avance.

Essaie comme ceci pour voir...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Commencer()
    Dim I As Long, J As Long, nbLignes As Long, LigneDest As Long
    Dim Cas As String
 
    'Tri des données par CAS et Ordre
    nbLignes = Cells(Rows.Count, "A").End(xlUp).Row
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A2:A" & nbLignes) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C2:C" & nbLignes) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A1:C" & nbLignes)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'Copie dans la feuille Feuil2
    LigneDest = 1
    For I = 2 To nbLignes
        Cas = Range("A" & I)
        For J = 2 To nbLignes
            If Range("A" & J) = Cas And I <> J Then
                LigneDest = LigneDest + 1
                Sheets("Feuil2").Range("A" & LigneDest) = Cas
                Sheets("Feuil2").Range("B" & LigneDest) = Range("B" & I) & " " & Range("B" & J)
            End If
        Next
    Next
 
End Sub