Script VBA de tri d'une colonne

Version imprimable

Bonjour,

J'ai 2 petits soucis avec un script que j'essaye de finaliser.

En gros voici la logique de mon script :

Il trie les "niveaux d'accès", dès qu'il tombe sur un nouveau niveau d'accès, il créé une nouvelle feuille, il nomme la feuille avec le nom du "niveau d'accès" en cours, il revient sur la feuille source, prend les données que je veux dans des variables, et reswitch sur la feuille de destination pour coller les données à la ligne.

ensuite il se deplace et compare la celulle du dessus, avec la cellule du dessous, pour vérifier si ce sont les mêmes; si ce sont les mêmes, il copie colle la ligne dans la feuille déjà existante.

Si les niveaux d'accès comparés ne sont pas les mêmes il créé une nouvelle feuille excell avec le nom actuel du niveau d'accès, et continu en copiant collant les ligne correspondant à ce "niveau d'accès".

J'ai 2 bugs :

Un qui en fait ce produit lorsque je suis touuuut à la fin du tableau (de 2800 lignes), je crois qu'il compare une cellule vide (la derniere après le tableau) avec la cellule précedente, et du coup j'ai une erreur débogage. mais c'est un faux positif puisqu'il a bien fait tout le travail. c'est un bug de fin de script.

et le 2 eme bug c'est que : par exemple si j'ai un groupe A avec 10 personnes et un groupes B avec 15 personnes : le script va donc créé une feuille A et B ensuite. le problème c'est que la Première personne du groupe B se retrouve à la derniere ligne de la feuille A, au lieu de se retrouver normalement à la premiere place de la feuille B.

voilà le code (attention ca pique les yeux, je suis débutant en VBA ^^)

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
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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
Sub TRIEAUTODROITSBADGES()
    ' Constants
    Const SourceSheet = "Niveaux d'accès - Personnes"
    Const AccessLevelTitle = "C1"
    Const AccessLevelTitleName = "Nom niveau d'accès"
    Const LastNameTitle = "A1"
    Const LastNameTitleName = "Nom"
    Const FirstNameTitle = "B1"
    Const FirstNameTitleName = "Prénom"
    Const WorkGroupTitle = "D1"
    Const WorkGroupTitleName = "Nom groupe de travail"
 
    ' Exploring variables.
    Dim CurrentAccessLevel As String
    Dim PreviousAccessLevel As String
    Dim SourceOffset As Integer
    Dim IntermediateOffset As Integer
    Dim DestinationOffset As Integer
    Dim ExitStoringLoop As Boolean
    Dim DestinationSheet As String
 
    ' Content variables.
    Dim CurrentLastName As String
    Dim CurrentFirstName As String
    Dim CurrentWorkGroup As String
 
    ' Initialization.
    Sheets(SourceSheet).Select
    Range(AccessLevelTitle).Select
    ActiveCell.Offset(1, 0).Select
    CurrentAccessLevel = ActiveCell.Value
    PreviousAccessLevel = ""
    DestinationSheet = ""
    SourceOffset = 1
    IntermediateOffset = 0
    DestinationOffset = 1
    ExitStoringLoop = False
    CurrentLastName = ""
    CurrentFirstName = ""
    CurrentWorkGroup = ""
 
    ' Exploration loop.
    While ((Not IsEmpty(CurrentAccessLevel)))
        ' Excluding duplicated values.
        If (CurrentAccessLevel <> PreviousAccessLevel) Then
            PreviousAccessLevel = CurrentAccessLevel
            ' Prepare Extract loop.
            IntermediateOffset = 0
            ' Extract loop.
            While (CurrentAccessLevel = PreviousAccessLevel)
                ' Retrieve data to extract.
                Sheets(SourceSheet).Select
                Range(LastNameTitle).Select
                    ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                    CurrentLastName = ActiveCell.Value
                Range(FirstNameTitle).Select
                    ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                    CurrentFirstName = ActiveCell.Value
                Range(WorkGroupTitle).Select
                    ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                    CurrentWorkGroup = ActiveCell.Value
                ' Check the destination sheet existence.
                DestinationSheet = "" & CurrentAccessLevel
                SheetExists = False
                For Each Ws In Worksheets
                    If (DestinationSheet = Ws.Name) Then
                        SheetExists = True
                    End If
                Next Ws
                If (SheetExists = False) Then
                    ' Add a new sheet at the end of the workbook if it does not exist.
                    Sheets.Add After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = DestinationSheet
                    ' Define the cells titles.
                    Range(AccessLevelTitle).Select
                    ActiveCell.Value = AccessLevelTitleName
                    Range(LastNameTitle).Select
                    ActiveCell.Value = LastNameTitleName
                    Range(FirstNameTitle).Select
                    ActiveCell.Value = FirstNameTitleName
                    Range(WorkGroupTitle).Select
                    ActiveCell.Value = WorkGroupTitleName
                End If
                ' Prepare storing loop.
                DestinationOffset = 0
                ExitStoringLoop = False
                ' Storing loop.
                While (ExitStoringLoop <> True)
                        Sheets(DestinationSheet).Select
                            ' Select destination cell.
                            Range(AccessLevelTitle).Select
                            ActiveCell.Offset(DestinationOffset, 0).Select
                            ' Check if the destination cell is well empty
                            If (IsEmpty(ActiveCell.Value)) Then
                                ' Store the new extracted value.
                                ActiveCell.Value = CurrentAccessLevel
                                Range(LastNameTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentLastName
                                Range(FirstNameTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentFirstName
                                Range(WorkGroupTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentWorkGroup
                                ExitStoringLoop = True
                            End If
                            ' Switch to the next destination cell.
                            DestinationOffset = DestinationOffset + 1
                Wend
                ' Switch to the next value inner access level scope.
                Sheets(SourceSheet).Select
                Range(AccessLevelTitle).Select
                ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                CurrentAccessLevel = ActiveCell.Value
                Rows(1).EntireRow.Delete
            Wend
            ' Update the source offset with the intermediate offset.
            SourceOffset = SourceOffset + IntermediateOffset - 1
        End If
        ' Switch to the next value.
        Sheets(SourceSheet).Select
        Range(AccessLevelTitle).Select
        SourceOffset = SourceOffset + 1
        ActiveCell.Offset(SourceOffset, 0).Select
        CurrentAccessLevel = ActiveCell.Value
    Wend
End Sub

Voilà, j'espère avoir été assez clair les amis.

j'espere que vous pourrez m'aider,

je suis à votre disposition pour toute information complémentaire.

Cordialement,

27/01/2016, 16h25
BDA53
:salut:

Si je peux t'aider, voici quelques remarques sur ton code :

1) Les constantes se déclarent plutôt au début de ton module et non dans une procédure en VBA.
Elles s'écrivent de préférence en majuscule pour les différencier des autres variables.

2) Il existe une fonction qui permet de comparer jusqu'à ce que une ligne soit vide :

Code:

Worksheets(1).End(xlDown).Row

3) La boucle do while est la négation de la boucle do until.
Donc tu peux très bien remplacer tes

Code:

While ((Not IsEmpty(CurrentAccessLevel)))

par

Code:

Do Until IsEmpty(CurrentAccessLevel)

4) Concernant ton deuxième bug, essaye avec End(xlDown).Row et tu nous diras comment ton code évolue

5) Cette partie de code est juste.
Code:

1 2 3 Dim SourceOffset As Integer Dim IntermediateOffset As Integer Dim DestinationOffset As Integer
Mais tu peux la simplifier en écrivant :

Code:

Dim SourceOffset, IntermediateOffset, DestinationOffset As Integer

Voilà voilà ! Après je n'ai pas pu tout lire dans ton code.
Il est tellement énorme que je me suis perdu plusieurs fois dedans :mouarf:
27/01/2016, 16h29
letienne
Bonjour,
c'est vrai que ça pique les yeux :)
à priori tes deux problèmes viennent de la gestion des fins de boucles.
Essaye déjà de nettoyer ton code en enlevant tous les select et autre activecell tu gagnera en lisibilité et en rapidité d'exécution, après ce n'est qu'une question d'algorithme mais perso là j'ai vraiment du mal à relire.
Citation:
Code:

1 2 3 4 Sheets(SourceSheet).Select Range(AccessLevelTitle).Select ActiveCell.Offset(1, 0).Select CurrentAccessLevel = ActiveCell.Value
devient :
Code:

1 2 CurrentAccessLevel = ThisWorkbook.Sheets(SourceSheet).Range(AccessLevelTitle).Offset(1, 0).Value
Thisworkbook permet de t'assurer que tu bosses sur le classeur contenant la macro (si tu en as plusieurs ouverts)
Il est conseillé de travailler avec Worksheets (feuille de données) plutôt que Sheets qui comporte également les feuilles de type graphique
27/01/2016, 16h33
letienne
Citation:
Envoyé par xela57

:salut:

5) Cette partie de code est juste.

Code:

1 2 3 Dim SourceOffset As Integer Dim IntermediateOffset As Integer Dim DestinationOffset As Integer

Mais tu peux la simplifier en écrivant :

Code:

Dim SourceOffset, IntermediateOffset, DestinationOffset As Integer
Heu, peut être que ça dépend des version mais sur les miennes (2007 et 2010), si on écrit comme ça les 2 premières variables sont déclarées de type variant et seule la troisième est en integer.
27/01/2016, 16h44
Menhir
Code:

1 2 3 4 Sheets(SourceSheet).Select Range(AccessLevelTitle).Select ActiveCell.Offset(1, 0).Select CurrentAccessLevel = ActiveCell.Value
Je ne vois pas trop l'intérêt qu'il y a à sélectionner une cellule (ligne 2) si ensuite tu utilises la cellule activée (et non la sélectionnée) ?

Rebonjour tout le monde !

Je voudrais savoir si quelqu'un n'aurait pas d'autres solution à me faire tester ? car plus je nettoie mon code! moins il fontctionne ^^

donc pour l'instant j'ai remis le code de base que j'avais fait,
J'ai juste remplacer avec le DO until proposé par Xela57 :

voilà le code :

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
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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
Sub Exctract()
 
' Constants
    Const SourceSheet = "Niveaux d'accès - Personnes"
    Const AccessLevelTitle = "C1"
    Const AccessLevelTitleName = "Nom niveau d'accès"
    Const LastNameTitle = "A1"
    Const LastNameTitleName = "Nom"
    Const FirstNameTitle = "B1"
    Const FirstNameTitleName = "Prénom"
    Const WorkGroupTitle = "D1"
    Const WorkGroupTitleName = "Nom groupe de travail"
 
    ' Exploring variables.
    Dim CurrentAccessLevel As String
    Dim PreviousAccessLevel As String
    Dim SourceOffset As Integer
    Dim IntermediateOffset As Integer
    Dim DestinationOffset As Integer
    Dim ExitStoringLoop As Boolean
    Dim DestinationSheet As String
 
    ' Content variables.
    Dim CurrentLastName As String
    Dim CurrentFirstName As String
    Dim CurrentWorkGroup As String
 
    ' Initialization.
    Sheets(SourceSheet).Select
    Range(AccessLevelTitle).Select
    ActiveCell.Offset(1, 0).Select
    CurrentAccessLevel = ActiveCell.Value
    PreviousAccessLevel = ""
    DestinationSheet = ""
    SourceOffset = 1
    IntermediateOffset = 0
    DestinationOffset = 1
    ExitStoringLoop = False
    CurrentLastName = ""
    CurrentFirstName = ""
    CurrentWorkGroup = ""
 
    ' Exploration loop.
     Do Until IsEmpty(CurrentAccessLevel)
        ' Excluding duplicated values.
        If (CurrentAccessLevel <> PreviousAccessLevel) Then
            PreviousAccessLevel = CurrentAccessLevel
            ' Prepare Extract loop.
            IntermediateOffset = 0
            ' Extract loop.
            While (CurrentAccessLevel = PreviousAccessLevel)
                ' Retrieve data to extract.
                Sheets(SourceSheet).Select
                Range(LastNameTitle).Select
                    ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                    CurrentLastName = ActiveCell.Value
                Range(FirstNameTitle).Select
                    ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                    CurrentFirstName = ActiveCell.Value
                Range(WorkGroupTitle).Select
                    ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                    CurrentWorkGroup = ActiveCell.Value
                ' Check the destination sheet existence.
                DestinationSheet = "" & CurrentAccessLevel
                SheetExists = False
                For Each Ws In Worksheets
                    If (DestinationSheet = Ws.Name) Then
                        SheetExists = True
                    End If
                Next Ws
                If (SheetExists = False) Then
                    ' Add a new sheet at the end of the workbook if it does not exist.
                    Sheets.Add After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = DestinationSheet
                    ' Define the cells titles.
                    Range(AccessLevelTitle).Select
                    ActiveCell.Value = AccessLevelTitleName
                    Range(LastNameTitle).Select
                    ActiveCell.Value = LastNameTitleName
                    Range(FirstNameTitle).Select
                    ActiveCell.Value = FirstNameTitleName
                    Range(WorkGroupTitle).Select
                    ActiveCell.Value = WorkGroupTitleName
                End If
                ' Prepare storing loop.
                DestinationOffset = 1
                ExitStoringLoop = False
                ' Storing loop.
                While (ExitStoringLoop <> True)
                        Sheets(DestinationSheet).Select
                            ' Select destination cell.
                            Range(AccessLevelTitle).Select
                            ActiveCell.Offset(DestinationOffset, 0).Select
                            ' Check if the destination cell is well empty
                            If (IsEmpty(ActiveCell.Value)) Then
                                ' Store the new extracted value.
                                ActiveCell.Value = CurrentAccessLevel
                                Range(LastNameTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentLastName
                                Range(FirstNameTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentFirstName
                                Range(WorkGroupTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentWorkGroup
                                ExitStoringLoop = True
                            End If
                            ' Switch to the next destination cell.
                            DestinationOffset = DestinationOffset + 1
                Wend
                ' Switch to the next value inner access level scope.
                Sheets(SourceSheet).Select
                Range(AccessLevelTitle).Select
                ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                CurrentAccessLevel = ActiveCell.Value
                Rows(1).EntireRow.Delete
            Wend
            ' Update the source offset with the intermediate offset.
            SourceOffset = SourceOffset + IntermediateOffset - 1
        End If
        ' Switch to the next value.
        Sheets(SourceSheet).Select
        Range(AccessLevelTitle).Select
        SourceOffset = SourceOffset + 1
        ActiveCell.Offset(SourceOffset, 0).Select
        CurrentAccessLevel = ActiveCell.Value
Loop
End Sub

J'ai toujours ce problème d'une ligne qui décale les dernieres personnes d'une feuille à l'autre (voir post 1), et un bug "faux positif" lorsqu'il arrive à la derniere cellule vide du tableau.

Merci d'avance les amis,

J'espère que vous pourrez me dépatouiller de tout ça ^^

Cordialement,

08/02/2016, 11h41
Menhir

Citation:

Envoyé par LOLGAMER

plus je nettoie mon code! moins il fontctionne ^^

Si tu montrais ce qui ne fonctionne pas et que tu expliquais le dysfonctionnement, peut-être serait-il possible de t'indiquer comment le faire fonctionner.

Coucou les amis !

pour info, j'ai beaucoup bossé dessus ^^ !

j'avais un problème dans mes offset ^^

voilà le code qui fonctionne parfaitement,

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
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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
 
Sub TRIEAUTODROITSBADGES()
' Constants
    Const SourceSheet = "Niveaux d'accès - Personnes"
    Const AccessLevelTitle = "C1"
    Const AccessLevelTitleName = "Nom niveau d'accès"
    Const LastNameTitle = "A1"
    Const LastNameTitleName = "Nom"
    Const FirstNameTitle = "B1"
    Const FirstNameTitleName = "Prénom"
    Const WorkGroupTitle = "D1"
    Const WorkGroupTitleName = "Nom groupe de travail"
 
    ' Exploring variables.
    Dim CurrentAccessLevel As String
    Dim PreviousAccessLevel As String
    Dim SourceOffset As Integer
    Dim IntermediateOffset As Integer
    Dim DestinationOffset As Integer
    Dim ExitStoringLoop As Boolean
    Dim DestinationSheet As String
 
    ' Content variables.
    Dim CurrentLastName As String
    Dim CurrentFirstName As String
    Dim CurrentWorkGroup As String
 
    ' Initialization.
    Sheets(SourceSheet).Select
    Range(AccessLevelTitle).Select
    ActiveCell.Offset(1, 0).Select
    CurrentAccessLevel = ActiveCell.Value
    PreviousAccessLevel = ""
    DestinationSheet = "aaa"
    SourceOffset = 1
    IntermediateOffset = 0
    DestinationOffset = 1
    ExitStoringLoop = False
    CurrentLastName = ""
    CurrentFirstName = ""
    CurrentWorkGroup = ""
 
    ' Exploration loop.
     Do Until IsEmpty(CurrentAccessLevel)
        ' Excluding duplicated values.
        If (CurrentAccessLevel <> PreviousAccessLevel) Then
            PreviousAccessLevel = CurrentAccessLevel
            ' Prepare Extract loop.
            IntermediateOffset = 0
            ' Extract loop.
            While (CurrentAccessLevel = PreviousAccessLevel)
                ' Retrieve data to extract.
                Sheets(SourceSheet).Select
                Range(LastNameTitle).Select
                    ActiveCell.Offset(IntermediateOffset, 0).Select
                    CurrentLastName = ActiveCell.Value
                Range(FirstNameTitle).Select
                    ActiveCell.Offset(IntermediateOffset, 0).Select
                    CurrentFirstName = ActiveCell.Value
                Range(WorkGroupTitle).Select
                    ActiveCell.Offset(IntermediateOffset, 0).Select
                    CurrentWorkGroup = ActiveCell.Value
                ' Check the destination sheet existence.
                DestinationSheet = "" & CurrentAccessLevel
                SheetExists = False
                For Each Ws In Worksheets
                    If (DestinationSheet = Ws.Name) Then
                        SheetExists = True
                    End If
                Next Ws
                If (SheetExists = False) Then
                    ' Add a new sheet at the end of the workbook if it does not exist.
                    Sheets.Add After:=Sheets(Sheets.Count)
                    ActiveSheet.Name = DestinationSheet
                    ' Define the cells titles.
                    Range(AccessLevelTitle).Select
                    ActiveCell.Value = AccessLevelTitleName
                    Range(LastNameTitle).Select
                    ActiveCell.Value = LastNameTitleName
                    Range(FirstNameTitle).Select
                    ActiveCell.Value = FirstNameTitleName
                    Range(WorkGroupTitle).Select
                    ActiveCell.Value = WorkGroupTitleName
                End If
                ' Prepare storing loop.
                DestinationOffset = 1
                ExitStoringLoop = False
                ' Storing loop.
                While (ExitStoringLoop <> True)
                        Sheets(DestinationSheet).Select
                            ' Select destination cell.
                            Range(AccessLevelTitle).Select
                            ActiveCell.Offset(DestinationOffset, 0).Select
                            ' Check if the destination cell is well empty
                            If (IsEmpty(ActiveCell.Value)) Then
                                ' Store the new extracted value.
                                ActiveCell.Value = CurrentAccessLevel
                                Range(LastNameTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentLastName
                                Range(FirstNameTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentFirstName
                                Range(WorkGroupTitle).Select
                                    ActiveCell.Offset(DestinationOffset, 0).Select
                                    ActiveCell.Value = CurrentWorkGroup
                                ExitStoringLoop = True
                            End If
                            ' Switch to the next destination cell.
                            DestinationOffset = DestinationOffset + 1
                Wend
                ' Switch to the next value inner access level scope.
                Sheets(SourceSheet).Select
                Range(AccessLevelTitle).Select
                ActiveCell.Offset(SourceOffset + IntermediateOffset, 0).Select
                CurrentAccessLevel = ActiveCell.Value
                If (CurrentAccessLevel = "") Then Exit Sub Else
                Rows(1).EntireRow.Delete
            Wend
            ' Update the source offset with the intermediate offset.
            SourceOffset = SourceOffset + IntermediateOffset - 1
        End If
        ' Switch to the next value.
        Sheets(SourceSheet).Select
        Range(AccessLevelTitle).Select
        SourceOffset = SourceOffset + 1
        ActiveCell.Offset(SourceOffset, 0).Select
        CurrentAccessLevel = ActiveCell.Value
Loop
End Sub