[XL-2007] Trie colonne avec premiere lettre en tête [Résolu]

[apdf1]

Bonjour,

Je recherche une façon de trier une liste de nom et adresse par ordre alpha et ajouter au début de chaque groupe de nom de la premiére lettre A ou B etc.

J'ai beau chercher, je n'ai rien trouvé. Avez-vous une solution?


Cordialement
Max

[francky74]

Bonjour,

Si tu sais faire le tri alphabétique dans le tableau excel avec la souris (sans macro), alors tu peux faire de même en utilisant l'enregistreur de macro. Tu n'auras alors qu'à recopier le code dans une macro.
Ensuite, pour ce qui est d'écrire la lettre lorsque la première lettre change, il te faudra lancer une recherche dans chaque case de la colonne. Avec la comme mid, il te faudra évaluer la première lettre de la première case afin de la comparer aux cases suivantes et dés que la lettre est différente, tu ajoutera une ligne à l'ebndroit voulu avec la lettre dedans.

Je ne sais pas si je suis clair mais tu peux me demander des éclaircissements là ou tu ne vois pas trop

[francky74]

Essaies déjà ce code et dis si il manque des trucs !

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
Sub Tri()
 
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
x = 2
y = x + 1
 
While Cells(x, 1) <> ""
Compare:
    If Mid(Cells(x, 1), 1, 1) = Mid(Cells(y, 1), 1, 1) Then
        y = y + 1
        GoTo Compare
    End If
    Cells(x, 1).Select
    Selection.Insert Shift:=xlDown
    Cells(x, 1) = Mid(Cells(x + 1, 1), 1, 1)
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    x = y + 1
    y = x + 1
Wend
 
End Sub

[apdf1]

Re,

Je te remercie beaucoup de ton code je l'ai mis dans un module et lorsque je fait appel au code j'ai un message d'erreur sur la ligne ci-dessous et j'ai oublié de te dire que j'ai 9 colonne:

Code :

Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

La méthode sort de la classe Range a échoué

@+
Max

[mercatog]

Ci-joint une proposition générique qui prend en considération les accents en première lettre à adapter au niveau du nom de la feuille.

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
Public Sub Sommaire()
Dim LastLig As Long, i As Long
Dim Lettre As String
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")                        'à adapter
'Ligne de la dernière cellule remplie de la colonne A
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Tri par ordre croissant
    .Range("A1:X" & LastLig).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, MatchCase:=False
    'on parcours la colonne A d'en bas vers le haut
    For i = LastLig To 2 Step -1
    'Si la cellule comporte un mot de plus d'une lettre
        If Len(.Range("A" & i).Value) > 1 Then
            'Dans lettre on mets la première lettre du mot en enlevant l'accent et en mettant en majuscule
            Lettre = SansAccent(Left(.Range("A" & i).Value, 1))
            'Si la première lettre du mots juste en haut est différent de Lettre (en enlevant l'accent et en mettant en majuscule)
            If SansAccent(Left(.Range("A" & i - 1).Value, 1)) <> Lettre Then
            'On insère une ligne
                .Rows(i).Insert
                'On la mets en gras, couleur rouje
                With .Rows(i).Font
                    .ColorIndex = 3
                    .Bold = True
                End With
                'on y insère en A Lettre
                .Range("A" & i).Value = Lettre
            End If
        End If
    Next i
End With
End Sub
 
Private Function SansAccent(Str As String) As String
Const AvecAcc = "éêèà" 'mettre ici tous les caractères accentués
Const SansAcc = "eeea" 'mettre ici leurs correspondant sans accent sur la même position
Dim i As Byte
 
'on remplace la lettre accentuée par son correspondant sans accent
Str = Left(Str, 1)
i = InStr(AvecAcc, LCase(Str))
If i > 0 Then
    SansAccent = UCase(Mid(SansAcc, i, 1))
Else
    SansAccent = UCase(Str)
End If
End Function

[apdf1]

Bonjour Mercatog

Je te remercie infiniment sa marche Nickel et même avec accent vraiment super, mais juste une petite chose si je peut me le permettre. Comment expliquer, j'ai ma liste de nom qui peut être modifiable à tous moment, et j'aimerais que lorsque je fait mon trie avec le code que tu ma fait sa se copy dans la feuil2.

Je reste a ta disposition si tu as besoin.

Bonne journée
Max

[mercatog]

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
Public Sub Sommaire()
Dim LastLig As Long, i As Long
Dim Lettre As String
 
Application.ScreenUpdating = False
With Worksheets("Feuil2")
    'On efface feuil2
    .UsedRange.Clear
    'On copie les données de Feuil1 vers Feuil2
    Worksheets("Feuil1").UsedRange.Copy .Range("A1")
    'Ligne de la dernière cellule remplie de la colonne A
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Tri par ordre croissant
    .Range("A1:X" & LastLig).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, MatchCase:=False
    'on parcours la colonne A d'en bas vers le haut
    For i = LastLig To 2 Step -1
        'Si la cellule comporte un mot de plus d'une lettre
        If Len(.Range("A" & i).Value) > 1 Then
            'Dans lettre on mets la première lettre du mot en enlevant l'accent et en mettant en majuscule
            Lettre = SansAccent(Left(.Range("A" & i).Value, 1))
            'Si la première lettre du mots juste en haut est différent de Lettre (en enlevant l'accent et en mettant en majuscule)
            If SansAccent(Left(.Range("A" & i - 1).Value, 1)) <> Lettre Then
                'On insère une ligne
                .Rows(i).Insert
                'On la mets en gras, couleur rouje
                With .Rows(i).Font
                    .ColorIndex = 3
                    .Bold = True
                End With
                'On y insère en A Lettre
                .Range("A" & i).Value = Lettre
            End If
        End If
    Next i
End With
End Sub
 
Private Function SansAccent(Str As String) As String
Const AvecAcc = "éêèà"                           'mettre ici tous les caractères accentués
Const SansAcc = "eeea"                           'mettre ici leurs correspondant sans accent sur la même position
Dim i As Byte
 
'on remplace la lettre accentuée par son correspondant sans accent
Str = Left(Str, 1)
i = InStr(AvecAcc, LCase(Str))
If i > 0 Then
    SansAccent = UCase(Mid(SansAcc, i, 1))
Else
    SansAccent = UCase(Str)
End If
End Function

[apdf1]

Re,

Merci beaucoup Mercatog, super boulot et très bien commentais

Je suis très content

Je te souhaite une bonne aprés midi

A bientôt

Max