Tri automatique par colonne

**jimbeam** · 16/01/2020, 22h28

Bonjour,

Je suis nouveau sur le forum et dans le monde d'office
Je sollicite votre aide car je suis bloqué avec un tableau que je souhaite réaliser.

J'utilise une macro (que je n'ai pas codée) pour archiver des lignes de mon tableau vers un classeur "archives"
La macro possède une fonction "restaurer". C'est là ou ça ne fonctionne pas comme je le voudrais... excel restaure bien la ligne mais ne la remet pas au bon endroit. J'ai donc eu l'idée de créer une colonne supplémentaire numérotée correspondant a mes lignes spécialement pour le tri.

Je souhaiterai savoir comment trier automatiquement les lignes entières qui ont été restaurés dans l'ordre croissant (en partant de la 4eme ligne). La première cellule des données à trier se trouve en B4.

P.S. si vous avez une solution plus simple pour que excel remette la ligne au bon endroit je suis preneur

Merci beaucoup pour votre temps,
Christian

Voici un aperçu de mon code pour copier les donnés :

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
 Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
If modeDebug Then Stop
 
    Sheets("Planning").Select
    Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Archives").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)
    Cells(Selection.Row, 1) = Date
    Sheets("Planning").Select
    Application.EnableEvents = False
    Range("A" & myRow & ":F" & myRow).Delete Shift:=xlShiftUp
    Application.EnableEvents = True
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

**ARTURO83** · 18/01/2020, 09h03

Bonjour,

En supposant que:
- la colonne comportant les N° de lignes est la colonne M
- la première ligne de données(hors ligne d'entêtes) commence en ligne 4, essayez ceci

Code :

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

Range("B4:M" & Range("B" & Rows.Count).End(xlUp).Row).Sort [M1], 1

Vous pouvez aussi utilisez l'enregistreur de macro pour faire le tri, récupérer le code et l'adapter à la plage des cellules.

Cdlt

**jimbeam** · 18/01/2020, 09h32

Bonjour

Merci pur votre retour
J'ai essayé avec le code que vous m'avez donné, mais ça ne fonctionne pas

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
Option Base 1
Sub archiveRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 31/07/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Tâches réalisées et supprime la ligne de la feuille Travail
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
If modeDebug Then Stop
 
    Sheets("Rétro planning").Select
    Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Tâches réalisées").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)
    Cells(Selection.Row, 1) = Date
    Sheets("Rétro planning").Select
    Application.EnableEvents = False
    Range("A" & myRow & ":F" & myRow).Delete Shift:=xlShiftUp
    Application.EnableEvents = True
 
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub
Sub recoverRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 01/08/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Travail et supprime la ligne de la feuille Archive
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
If modeDebug Then Stop
 
    Sheets("Tâches réalisées").Select
    Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Rétro planning").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)
    Sheets("Tâches réalisées").Select
    Application.EnableEvents = False
    Cells(myRow, 1).EntireRow.Delete Shift:=xlShiftUp
    Application.EnableEvents = True
 
    ' Tri personnalisé
 
Range("B4:B" & Range("B" & Rows.Count).End(xlUp).Row).Sort [B1], 1
 
    'Fin du tri
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

J'ai réussi a faire un tri avec l'enregistreur de macro qui fonctionne mais je pense n'est pas parfait.
De plus à la fin de la macro les cellules restent sélectionnées ; je pense que c'est du a la fonction "Range(MaPlage).Select" mais je ne sais pas comment faire sans le .Select

Voici mon code (rudimentaire) qui fonctionne :

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
79
80
81
82
83
84
85
86
87
88
89
90
91
 
Option Explicit
Option Base 1
Sub archiveRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 31/07/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Tâches réalisées et supprime la ligne de la feuille Travail
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
If modeDebug Then Stop
 
    Sheets("Rétro planning").Select
    Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Tâches réalisées").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)
    Cells(Selection.Row, 1) = Date
    Sheets("Rétro planning").Select
    Application.EnableEvents = False
    Range("A" & myRow & ":F" & myRow).Delete Shift:=xlShiftUp
    Application.EnableEvents = True
 
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub
Sub recoverRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 01/08/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Travail et supprime la ligne de la feuille Archive
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
If modeDebug Then Stop
 
    Sheets("Tâches réalisées").Select
    Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Rétro planning").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)
    Sheets("Tâches réalisées").Select
    Application.EnableEvents = False
    Cells(myRow, 1).EntireRow.Delete Shift:=xlShiftUp
    Application.EnableEvents = True
 
    ' Tri personnalisé
 
     Range("A4:F111").Select
    ActiveWorkbook.Worksheets("Rétro planning").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Rétro planning").Sort.SortFields.Add2 Key:=Range( _
        "B4:B111"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Rétro planning").Sort
        .SetRange Range("A4:F111")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    'Fin du tri
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

Merci infiniment,
Christian

**ARTURO83** · 18/01/2020, 10h27

Je reprends ma formule avec vos données

Code :

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

    Range("A4:F" & Range("A" & Rows.Count).End(xlUp).Row).Sort [F4], 1

Réessayez

**jimbeam** · 18/01/2020, 10h45

Je suis désolé je ne doit pas faire tout comme il faut, je n'arrive pas à faire fonctionner

Je vous joint tout le fichier pour que vous ayez un aperçu

**ARTURO83** · 18/01/2020, 10h48

D'après votre fichier, essayez ceci

Code :

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

    Range("B4:F" & Range("B" & Rows.Count).End(xlUp).Row).Sort [B4], 1

**jimbeam** · 18/01/2020, 12h39

Ça ne fonctionne pas et je ne sais pas pourquoi... à quel endroit faut -il insérer la ligne de code exactement ? Je l'ai mise au même endroit que l'autre script, cad dans le module à la suite ?

**306xshdi** · 18/01/2020, 15h31

Envoyé par ARTURO83

D'après votre fichier, essayez ceci

Code :

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

    Range("B4:F" & Range("B" & Rows.Count).End(xlUp).Row).Sort [B4], 1

Quelques explications:

Range("B" & Rows.Count).End(xlUp).Row = Trouve automatiquement la dernière ligne dans la colonne B où il y a une valeur donc Range("B4:F" & Range("B" & Rows.Count).End(xlUp).Row) = ta plage de données

Et .Sort [B4], 1 = le tri en fonction des critères

Arturo t'a tout groupé sur une ligne alors que l’enregistreur fait action par action !

**jimbeam** · 18/01/2020, 17h15

Bonsoir,

Super merci le code fonctionne et les explications c'est plus clair pour moi qui suis novice en VBA.

Cependant les cellules restent sélectionnés à la fin de l'opération

Je me demande si c'est pas à cause de ces autres .Select respectivement

Code :

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

1
2
3
4
5
6
7
8
9
10
    Sheets("Rétro planning").Select
    Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Tâches réalisées").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)
    Cells(Selection.Row, 1) = Date
    Sheets("Rétro planning").Select
    Application.EnableEvents = False
    Range("A" & myRow & ":F" & myRow).Delete Shift:=xlShiftUp
    Application.EnableEvents = True

Et

Code :

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

1
2
3
4
5
6
7
8
9
    Sheets("Tâches réalisées").Select
    Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Rétro planning").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)
    Sheets("Tâches réalisées").Select
    Application.EnableEvents = False
    Cells(myRow, 1).EntireRow.Delete Shift:=xlShiftUp
    Application.EnableEvents = True

Comment puis-je me débarrasser de cette sélection s'il vous plait ?

**306xshdi** · 18/01/2020, 17h43

En ne passant pas par la sélection.

Par exemple:

Sheets("Rétro planning").Select
Range("B" & myRow & ":F" & myRow).Copy

devient

Code :

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

Sheets("Rétro planning").Range("B" & myRow & ":F" & myRow).Copy

ou

Code :

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

1
2
3
Sheets("Rétro planning").Select
    Range("B100000").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial (xlPasteFormulasAndNumberFormats)

devient

Code :

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

Sheets("Rétro planning").Range("B100000").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteFormulasAndNumberFormats)

Sinon, avec ton code actuel, sélectionne simplement 1 cellule:

Code :

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

ThisWorkbook.Sheets("Rétro planning").Range("B1").select 'exemple avec la cellule B1

**jimbeam** · 18/01/2020, 18h42

Bonsoir,

Je suis arrivé à ça...

Code :

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

1
2
3
4
5
6
    Sheets("Rétro planning").Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Tâches réalisées").Range("B100000").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteFormulasAndNumberFormats)
    Cells(Selection.Row, 1) = Date
    Sheets("Rétro planning").Application.EnableEvents = False
    Range("A" & myRow & ":F" & myRow).Delete Shift:=xlShiftUp
    Application.EnableEvents = True

Et ça

Code :

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

1
2
3
4
5
    Sheets("Tâches réalisées").Range("B" & myRow & ":F" & myRow).Copy
    Sheets("Rétro planning").Range("B100000").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteFormulasAndNumberFormats)
    Sheets("Tâches réalisées").Application.EnableEvents = False
    Cells(myRow, 1).EntireRow.Delete Shift:=xlShiftUp
    Application.EnableEvents = True

Mais il doit y avoir un couac car mon code ne fonctionne pas :/

**ARTURO83** · 19/01/2020, 08h05

Bonjour,

Normal que cela ne fonctionne pas, il n'y a rien qui correspond.
Voici le fichier corrigé entièrement
Pièce jointe 531761

Le code dans le module de la feuille "Rétro planning"

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
Private Sub Worksheet_Change(ByVal Target As Range)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 31/07/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Archives et supprime la ligne de la feuille Travail
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
If modeDebug Then Stop
 
    If Not Intersect(Target.Cells(1), Range("M4:B" & Range("B100000").End(xlUp).Row)) _
        Is Nothing And LCase(Target.Cells(1).Value) = "x" Then
        archiveRow (Target.Row)
    End If
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

Le code dans le module de la feuille "Tâches réalisées"

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
Private Sub Worksheet_Change(ByVal Target As Range)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 31/07/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Archives et supprime la ligne de la feuille Travail
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
If modeDebug Then Stop
 
    If Not Intersect(Target.Cells(1), Range("M4:M" & Range("B100000").End(xlUp).Row)) _
        Is Nothing And LCase(Target.Cells(1).Value) = "x" Then
        recoverRow (Target.Row)
    End If
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
End Sub

Le code dans le module standard "Module1"

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
79
80
81
Option Explicit
Option Base 1
 
Dim f1 As Worksheet, f2 As Worksheet
 
Sub archiveRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 31/07/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Tâches réalisées et supprime la ligne de la feuille Travail
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    Dim NwLig As Long
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
    If modeDebug Then Stop
    Set f1 = Sheets("Tâches réalisées")
    Set f2 = Sheets("Rétro planning")
 
    f2.Range("A" & myRow & ":F" & myRow).Copy
    NwLig = f1.Range("B" & Rows.Count).End(xlUp).Row + 1
    f1.Range("A" & NwLig).PasteSpecial (xlPasteFormulasAndNumberFormats)
    f1.Cells(NwLig, 1) = Date
    f2.Application.EnableEvents = False
    f2.Range("A" & myRow & ":M" & myRow).Delete Shift:=xlShiftUp
    Application.EnableEvents = True
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub recoverRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 01/08/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Travail et supprime la ligne de la feuille Archive
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
    If modeDebug Then Stop
    Set f1 = Sheets("Tâches réalisées")
    Set f2 = Sheets("Rétro planning")
 
    f1.Range("B" & myRow & ":F" & myRow).Copy
    f2.Range("B100000").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteFormulasAndNumberFormats)
    Application.EnableEvents = False
    f1.Cells(myRow, 1).EntireRow.Delete Shift:=xlShiftUp
    Application.EnableEvents = True
    ' Tri personnalisé
    f2.Select
    Range("A4:F" & Range("B" & Rows.Count).End(xlUp).Row).Sort [B4], 1
 
    'Fin du tri
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Rappel sur le fonctionnement: mettre un "x" dans la colonne "M" en face de la ligne à recopier dans l'une ou l'autre feuille

Cdlt

**jimbeam** · 19/01/2020, 21h40

Bonjour a tous

Super merci beaucoup pour votre aide.
Je souhaiterais mettre une bordure fixe autour du tableau et qui ne bouge pas lorsque je restaure mes données (bloquée à B111 par exemple ou adaptable). Je souhaiterais aussi créer une bordure autour de certains titres. Comment faire pour conserver la mise en page en copiant les lignes svp ?

Merci

**ARTURO83** · 20/01/2020, 06h23

Bonjour

le fichier modifié
Pièce jointe 532003

Le code dans le module standard

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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
Option Explicit
Option Base 1
 
Dim f1 As Worksheet, f2 As Worksheet, FeuilleActive As String
 
Sub archiveRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 31/07/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Tâches réalisées et supprime la ligne de la feuille Travail
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    Dim NwLig As Long
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
    If modeDebug Then Stop
    Set f1 = Sheets("Tâches réalisées")
    Set f2 = Sheets("Rétro planning")
 
    f2.Range("A" & myRow & ":F" & myRow).Copy
    NwLig = f1.Range("B" & Rows.Count).End(xlUp).Row + 1
    f1.Range("A" & NwLig).PasteSpecial (xlPasteFormulasAndNumberFormats)
    f1.Cells(NwLig, 1) = Date
    f2.Application.EnableEvents = False
    f2.Range("A" & myRow & ":M" & myRow).Delete Shift:=xlShiftUp
    Application.EnableEvents = True
 
    'Application d'un quadrillage
    FeuilleActive = "Tâches réalisées"
    Quadrillage
    FeuilleActive = "Rétro planning"
    Quadrillage
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub recoverRow(myRow As Long)
' **************************************************************************************
' Author        : Christian CROCHE
' Date          : 01/08/2019
' Description   : Ajouter un "x" ou "X" dans la colonne M lance une copie de la ligne
'                 dans la feuille Travail et supprime la ligne de la feuille Archive
' **************************************************************************************
 
    Dim myVariable As String, modeDebug As Boolean
    modeDebug = False
 
    If Not modeDebug Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
    End If
 
' Comment
    If modeDebug Then Stop
    Set f1 = Sheets("Tâches réalisées")
    Set f2 = Sheets("Rétro planning")
 
    f1.Range("B" & myRow & ":F" & myRow).Copy
    f2.Range("B100000").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteFormulasAndNumberFormats)
    Application.EnableEvents = False
    f1.Cells(myRow, 1).EntireRow.Delete Shift:=xlShiftUp
    Application.EnableEvents = True
    ' Tri personnalisé
    f2.Select
    Range("A4:F" & Range("B" & Rows.Count).End(xlUp).Row).Sort [B4], 1
 
    'Application d'un quadrillage
    FeuilleActive = "Rétro planning"
    Quadrillage
    FeuilleActive = "Tâches réalisées"
    Quadrillage
 
    If Not modeDebug Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Quadrillage()
    Dim DerLig As Long, DerCol As Long
    Application.ScreenUpdating = False
    Sheets(FeuilleActive).Select
    DerLig = Sheets(FeuilleActive).Range("B4").End(xlDown).Row
    If FeuilleActive = "Tâches réalisées" Then
        DerCol = 7
        If [C5] = "" Then DerLig = 4
    ElseIf FeuilleActive = "Rétro planning" Then
        DerCol = 6
        If [C4] = "" Then DerLig = 3
    End If
    Cells.Borders().LineStyle = xlNone
    Range(Cells(2, "A"), Cells(DerLig, DerCol)).Borders().Weight = xlThin
    Range(Cells(1, "A"), Cells(1, DerCol)).Borders().Weight = xlMedium
    If FeuilleActive = "Tâches réalisées" Then
        Range("A2:G4").Borders().Weight = xlMedium
    ElseIf FeuilleActive = "Rétro planning" Then
        Range("A2:F3").Borders().Weight = xlMedium
    End If
End Sub

Cdlt

**jimbeam** · 20/01/2020, 06h42

Bonjour ARTHURO83,

Super merci c'est l'idée
Et comment puis-je rajouter un nouveau formatage pour une ligne dans le fichier? Par exemple si je veux que mon titre sur la ligne 16 (lorsque les lignes sont toutes présentes) soit entouré d'une bordure épaisse et la hauteur du format de la cellule soit différente. Il me faudrait en fait que les bordures et le formatage suive toujours les même titre (même si l'archivage fait que le numéro de ligne change)

Est que c'est possible avec excel ?

merci encore belle semaine
Christian

**ARTURO83** · 20/01/2020, 06h47

Code :

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

1
2
Envoyé par jimbeam
Et comment puis-je rajouter un nouveau formatage pour une ligne dans le fichier? Par exemple si je veux que mon titre sur la ligne 16 (lorsque les lignes sont toutes présentes) soit entouré d'une bordure épaisse et la hauteur du format de la cellule soit différente ?

Sur quelle feuille?
La ligne est-elle choisie par vous ou bien est-ce celle qui est déplacée?

**jimbeam** · 21/01/2020, 20h42

Bonsoir,

Premièrement , je souhaiterai ajouter un formatage (bordure épaisse, hauteur de ligne) aux lignes de sous-titre comme l4, l16 ,l27, l40 ...
Ces lignes sont sur la feuille 1 Rétro Planning sont choisies par moi et ne doivent pas être déplacées.

Comment conserver ce formatage de ligne lorsqu'on Archive/Restaure ?

Deuxièmement pour un quadrillage donné (par ex dans la ligne de code

Code :

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

 Range("A2:F3").Borders().Weight = xlMedium

je souhaiterais pouvoir choisir par exemple de mettre soit uniquement les bordures extérieures, soit les traits verticaux ou les traits horizontaux de séparation, ou bien combiner ces possibilités.

Je chipote un peu ce sont des détails mais ça me servira pour d'autres fois...

Merci encore

Bien à vous,
Christian

**ARTURO83** · 22/01/2020, 08h32

Bonjour,

Vous pouvez faire ces actions en utilisant l'enregistreur de macros et recopier le résultat, en l'adaptant si besoin, dans votre macro.

Cdlt

**jimbeam** · 23/01/2020, 19h38

Bonsoir,

J'ai essayé ce que vous avez dit, malheureusement cela ne fonctionne pas car par exemple

Code :

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

1
2
3
4
5
Sub Macro1()
    Rows("27:27").Select
    Selection.RowHeight = 30
    Range("C2").Select
End Sub

ne fonctionne plus une fois une tâche accomplie avant la ligne 27 celle-ci devient la ligne 26
Il me faudrait un code qui puisse se baser sur les valeurs de la colonne B qui ne changent pas par exemple si chiffre dans colonne B = 24 alors RowHeight = 30

Merci
Bonne soirée
Christian

**ARTURO83** · 24/01/2020, 06h37

Bonjour,

Formatez vos lignes de sous-titres comme vous le souhaitez, le code suivant interdit le marquage d'un "x" dans la colonne M sur ces lignes de sous-titres.
Code dans le module de la feuille "Rétro_planning"

Code :

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

1
2
3
4
5
6
7
8
9
10
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    Num = Cells(Target.Row, "B")
    Select Case Num
        Case 1, 13, 24, 37, 56, 76, 80, 91, 96, 100, 104
            Cells(Target.Row, "N").Select
    End Select
    Application.EnableEvents = True
End Sub

Le fichier
Pièce jointe 533209

Cdlt

Tri automatique par colonne

Macros et VBA Excel

Discussions similaires

Partager

Partager