VBA complexe issu d'un tableau de données a transformer

Version imprimable

11/08/2016, 10h41
frederic89

1 pièce(s) jointe(s)

VBA complexe issu d'un tableau de données a transformer

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

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:

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

11/08/2016, 16h34
frederic89

Déja résolu

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

Citation:

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:

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