Tri et mise en forme

**Walker_** · 27/02/2021, 13h33

Bonjour à tous et à toutes,

Dans le cadre d'un projet personnel, je souhaite développer une macro afin de vérifier un travail que je réalise manuellement. Le but de cette macro est de reproduire le même formalisme et de vérifier que j'obtiens bien la même chose.

Je dispose un tableau avec plusieurs colonnes (Pièces, nom, taille et des longueurs) et je souhaite les "ranger" d'une manière précise. Je dispose pour cela de ces conditions :
- Si la pièce, le nom et la taille sont identique avec la ligne -1 , alors la longueur doit s'inscrire sur la ligne -1 et la colonne +1
- Si la pièce, le nom sont identiques par rapport à la ligne - 1 mais si la taille diffère, alors nous passons sur une nouvelle ligne et nous continuons d'incrémenter sa position dans la colonne
- Si le nom diffère de la ligne - 1, alors nous passons à une nouvelle ligne et nous revenons à la colonne initiale
- Si le nom de la pièce, le nom et la taille sont identiques à une ligne précédente, nous revenons sur cette ligne et nous incrémentons la colonne.

Je suis conscient que cela peut paraitre confus, c'est pourquoi je joins un exemple à ce message. Visuellement, nous devons obtenir une forme "d'escalier" pour montrer la continuité.
J'ai commencé de mon côté un programme mais je n'ai réussi à coder que les conditions "simples" et le résultat obtenu n'est pas fiable.

Je vous remercie d'avance pour toute aide et pour votre lecture !

Cordialement,

Walker_

**ARTURO83** · 28/02/2021, 08h40

Bonjour,

Essayez ceci

Pièce jointe 592113

le code

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Option Explicit
 
Sub Affiche_Resultat()
    Dim DerLig_f1 As Long, i As Long, c As Long, LigTrouvee As Long, NbLig As Long
    Dim f1 As Worksheet, f2 As Worksheet
    Dim Valeur As Double
 
    Application.ScreenUpdating = False
    Set f1 = Sheets("Entrée")
    Set f2 = Sheets("Résultat")
 
    DerLig_f1 = f1.Range("D" & Rows.Count).End(xlUp).Row
    f1.Range("S2:Z" & DerLig_f1).ClearContents
    f2.Range("B1:Q" & DerLig_f1).Value = f1.Range("B1:Q" & DerLig_f1).Value
    'Premièrement, on concatène les critères (Pièce, Nom, Taille) puis on numérote les lignes en fonction de ces critères
    f2.Range("S2:S" & DerLig_f1).FormulaR1C1 = "=RC[-16]&"" ""&RC[-15]&"" ""&RC[-14]"
    f2.Range("T2").FormulaR1C1 = "1"
    f2.Range("T3:T" & DerLig_f1).FormulaR1C1 = "=IF(COUNTIF(R2C19:R[-1]C[-1],RC[-1])>0,INDIRECT(""T""&MATCH(RC[-1],R2C19:R[-1]C[-1],0)+1),MAX(R2C20:R[-1]C20)+1)"
    f2.Range("U2:U" & DerLig_f1).FormulaR1C1 = "=IF(RC[-17]<>R[-1]C[-17],1,"""")"
    f2.Range("S2:U" & DerLig_f1).Value = f2.Range("S2:U" & DerLig_f1).Value
 
 
    For i = DerLig_f1 To 2 Step -1
        If f2.Cells(i, "U") = "" Then
            'on recherche si le même numéro existe dans la colonne U
            Valeur = f2.Cells(i, "T")
            On Error Resume Next
            LigTrouvee = Application.WorksheetFunction.Match(Valeur, f2.Range("T1:T" & i - 1), 0)
            If LigTrouvee = "" Then
                'On compte le nombre de Lignes qui la sépare de la première ligne du même nom
                NbLig = 0
                For c = i To 2 Step -1
                    If f2.Cells(c, "U") = 1 Then Exit For
                    If f2.Cells(c, "U") <> 1 Then
                        NbLig = NbLig + 1
                    End If
                Next c
                f2.Cells(i, 21 + NbLig) = f2.Cells(i, "L")
            Else
                'On compte le nombre de Lignes qui les sépare
                NbLig = i - LigTrouvee
                If f2.Cells(LigTrouvee, "U") = 1 Then
                    f2.Cells(LigTrouvee, 21 + NbLig) = f2.Cells(i, "L")
                Else
                    f2.Cells(LigTrouvee, 21 + NbLig + 1) = f2.Cells(i, "L")
                End If
                NbLig = 0
            End If
            f2.Cells(i, "S").ClearContents
            LigTrouvee = ""
        Else
            f2.Cells(i, "U") = f2.Cells(i, "L")
        End If
    Next i
 
    'Suppression des lignes vides
    For i = DerLig_f1 To 2 Step -1
        If Application.WorksheetFunction.CountA(Range(f2.Cells(i, "U"), f2.Cells(i, "Z"))) = 0 Then f2.Rows(i).Delete
    Next i
 
    f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=IF(RC[8]="""","""",RC[8])"
    f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).Value = f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).Value
    f2.Select
    f2.Columns("S:Z").ClearContents
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

**Walker_** · 28/02/2021, 21h08

Bonjour Arturo,

Je vous remercie grandement d'avoir pris la peine de m'aider ! J'ai pris la peine d'essayer de comprendre le code que vous avez réalisé mais je n'ai pas tout saisi... Je n'arrive pas à comprendre le résultat final entre l'exemple désiré (onglet résultat du fichier Excel originel ) et le résultat obtenu avec l'aide de la macro. Est-ce une une mauvaise compréhension de votre programme ?

Merci encore pour votre aide et pour votre retour !

**ARTURO83** · 01/03/2021, 06h08

Bonjour,

A vouloir peaufiner, j'ai fait une bêtise, en modifiant un type de variable au dernier moment, je ne me suis pas rendu compte que le résultat était différent. J'ai vu aussi que je conservais 2 fois la même valeur (en colonne L et M) ça aussi c'est corrigé.

le fichier
Pièce jointe 592167

Le code

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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Option Explicit
 
Sub Affiche_Resultat()
    Dim DerLig_f1 As Long, DerLig_f2 As Long, i As Long, c As Long, LigTrouvee As Long, NbLig As Long
    Dim f1 As Worksheet, f2 As Worksheet
    Dim Valeur As Double
 
    Application.ScreenUpdating = False
    Set f1 = Sheets("Entrée")
    Set f2 = Sheets("Résultat")
 
    DerLig_f1 = f1.Range("D" & Rows.Count).End(xlUp).Row
    f2.Range("B1:Q" & DerLig_f1).Value = f1.Range("B1:Q" & DerLig_f1).Value
    'Premièrement, on concatène les critères (Pièce, Nom, Taille) puis on numérote les lignes en fonction de ces critères
    f2.Range("S2:S" & DerLig_f1).FormulaR1C1 = "=RC[-16]&"" ""&RC[-15]&"" ""&RC[-14]"
    f2.Range("T2").FormulaR1C1 = "1"
    f2.Range("T3:T" & DerLig_f1).FormulaR1C1 = "=IF(COUNTIF(R2C19:R[-1]C[-1],RC[-1])>0,INDIRECT(""T""&MATCH(RC[-1],R2C19:R[-1]C[-1],0)+1),MAX(R2C20:R[-1]C20)+1)"
    f2.Range("U2:U" & DerLig_f1).FormulaR1C1 = "=IF(RC[-17]<>R[-1]C[-17],1,"""")"
    f2.Range("S2:U" & DerLig_f1).Value = f2.Range("S2:U" & DerLig_f1).Value
 
 
    For i = DerLig_f1 To 2 Step -1
        If f2.Cells(i, "U") = "" Then
            'on recherche si le même numéro existe dans la colonne U
            Valeur = f2.Cells(i, "T")
            On Error Resume Next
            LigTrouvee = Application.WorksheetFunction.Match(Valeur, f2.Range("T1:T" & i - 1), 0)
            If LigTrouvee = 0 Then
                'On compte le nombre de Lignes qui la sépare de la première ligne du même nom
                NbLig = 0
                For c = i To 2 Step -1
                    If f2.Cells(c, "U") = 1 Then Exit For
                    If f2.Cells(c, "U") <> 1 Then
                        NbLig = NbLig + 1
                    End If
                Next c
                f2.Cells(i, 21 + NbLig) = f2.Cells(i, "L")
            Else
                'On compte le nombre de Lignes qui les sépare
                NbLig = i - LigTrouvee
                If f2.Cells(LigTrouvee, "U") = 1 Then
                    f2.Cells(LigTrouvee, 21 + NbLig) = f2.Cells(i, "L")
                Else
                    f2.Cells(LigTrouvee, 21 + NbLig + 1) = f2.Cells(i, "L")
                End If
                NbLig = 0
            End If
            f2.Cells(i, "S").ClearContents
            LigTrouvee = 0
        Else
            f2.Cells(i, "U") = f2.Cells(i, "L")
        End If
    Next i
 
    f2.Select
    'Suppression des lignes vides
    For i = DerLig_f1 To 2 Step -1
        If Application.WorksheetFunction.CountA(Range(f2.Cells(i, "U"), f2.Cells(i, "Z"))) = 0 Then
            f2.Rows(i).Delete
        End If
    Next i
 
    f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=IF(RC[9]="""","""",RC[9])"
    f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).Value = f2.Range("M2:Q" & Range("D" & Rows.Count).End(xlUp).Row).Value
 
    'Suppression des doublons
    DerLig_f2 = f2.Range("D" & Rows.Count).End(xlUp).Row
    For i = DerLig_f2 To 2 Step -1
        If Application.WorksheetFunction.CountIf(Range(f2.Cells(i, "M"), f2.Cells(i, "Q")), f2.Cells(i, "L")) > 0 Then
            f2.Cells(i, "L").ClearContents
        End If
    Next i
 
    f2.Columns("S:Z").ClearContents
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

Tri et mise en forme

Macros et VBA Excel

Discussions similaires

Partager

Partager