Discussion :

[patricktoulon]

re
perso je préfère la 1 présentation de rdurupt sur une colonne

elle est plus lisible que la dernière d'autant plus que pour les éventuels ajouts ou suppression
le code qui en découlera sera moins compliqué et moins contraignant

[luckyalan]

Bonsoir,
@rdurupt
tu as dit dans un précédent post qu'on allait atteindre la perfection, j'ai l'impression qu'on y est...
je te dis un énorme merci pour ton aide

une petite question complémentaire si tu veux bien :
avec ce modèle de catalogue si on change de page au milieu de la liste d'un artiste, on va se retrouver sur la nouvelle page avec une liste de titres sans artiste.
y a-t-il une parade faisable ou pas ?
merci encore, tu as vraiment fait un boulot formidable,que je suis malheureusement incapable d'analyser vu mes connaissances hyper basiques en VBA, mais que je peux par contre tout à fait apprécier
mille merci
merci également à tous les autres qui ont pris la peine de s'intéresser à mon sujet
Amitiés à tous

[Invité]

Je travail sur une version intermédiaire entre la première et la dernière!

Je trouve également que la présentation sur une colonne est plus jolie!

Mais je pense en respectant cette mises en forme que l'on peut tabler sur 4 colonne.

On peut également regarder le sauts de pages!

[Invité]

Bonjour,

Code Classe1 :

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
Public titre
Public Artste As String
Dim nb As Integer
Dim Dico
Dim Spage As Boolean
 
 
Private Sub Class_Initialize()
Set Dico = CreateObject("Scripting.Dictionary")
ReDim titre(nb)
End Sub
Public Sub Ajouter(T As String)
v = Split(T, "£")
 If Dico.Exists(v(1)) = False Then
    Dico.Add v(1), v(1)
    ReDim Preserve titre(nb)
    Artste = Trim("" & v(0))
    titre(nb) = v(1)
    nb = nb + 1
    End If
End Sub
 
Public Sub Ecrire(Feuille As Worksheet)
Dim derL As Long
derL = Feuille.Range("A1").CurrentRegion.Rows.Count
If Trim("" & Feuille.Cells(derL, "c")) <> "" Then derL = derL + 1
EcrireArtiste Feuille, derL
c = 0
If Artste = "Lara Fabian" Then
'MsgBox ""
End If
For i = 1 To UBound(titre) + 1
'DoEvents
    Feuille.Cells(derL, "C").Offset(0, c) = titre(i - 1)
 
    If Feuille.Rows(derL).PageBreak = -4105 Then
    Spage = True
    EcrireArtiste Feuille, derL
    End If
 
    If i Mod 2 = 0 Then derL = derL + 1: c = -1: Spage = False
    c = c + 1
Next
End Sub
Private Sub EcrireArtiste(Feuille As Worksheet, derL As Long)
Feuille.Cells(derL, "B") = Artste
Feuille.Cells(derL, "B").Font.Bold = True
Feuille.Cells(derL, "B").Font.Underline = xlUnderlineStyleSingle
Feuille.Cells(derL, "B").Interior.ColorIndex = 45
Feuille.Cells(derL, "B").Font.Size = 12
DoEvents
End Sub

Code Classe2 :

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
Public Lettre As String
Public DicoArtiste As Object
Public titre
Public Artste As String
Dim nb As Integer
Dim Dico
Dim Alphabet As Object
 
Public cl As Classe1
 
Private Sub Class_Initialize()
Set DicoArtiste = CreateObject("Scripting.Dictionary")
End Sub
Public Sub Ecrire(Feuille As Worksheet)
Dim derL As Long
derL = Feuille.Range("A1").CurrentRegion.Rows.Count + 1
If DicoArtiste.Count > 0 Then
Feuille.Cells(derL, "a") = Lettre
Feuille.Cells(derL, "a").Font.Bold = True
Feuille.Cells(derL, "a").Font.Underline = xlUnderlineStyleSingle
Feuille.Cells(derL, "A").Font.Size = 16
Feuille.Cells(derL, "A").Interior.ColorIndex = 16
 i = DicoArtiste.items
    For l = 0 To DicoArtiste.Count - 1
      i(l).Ecrire Feuille
    Next
 End If
End Sub

Code Module1 :

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
Sub Etst() 'premiere boucle te fait lire la premiere colonne
Application.ScreenUpdating = False
Application.EnableEvents = True
Dim R As Range, cl As Classe1, Alphabet As Object, LL As Classe2
Set Alphabet = CreateObject("Scripting.Dictionary")
For l = 0 To 9
     Set LL = New Classe2
     LL.Lettre = CStr(l)
     Alphabet.Add CStr(l), LL
     Set LL = Nothing
Next
 
For l = 0 To 25
     Set LL = New Classe2
     LL.Lettre = Chr(65 + l)
     Alphabet.Add Chr(65 + l), LL
     Set LL = Nothing
Next
Dim DicoArtiste As Object
 Set DicoArtiste = CreateObject("Scripting.Dictionary")
Set R = ThisWorkbook.Sheets("Feuil1").UsedRange
'With ThisWorkbook.Sheets("Feuil1").Sort
'        .SetRange Range(R.Address)
'        .Header = xlNo
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With
Set Dico = CreateObject("Scripting.Dictionary")
 
For l = 1 To R.Rows.Count
     If Dico.Exists(Split(R(l, 1), ".")(0)) = False Then
        Dico.Add Split(R(l, 1), ".")(0), Split(R(l, 1), ".")(0)
        If Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Exists(Split(R(l, 1), "£")(0)) = False Then
            Set cl = New Classe1
            Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Add Split(R(l, 1), "£")(0), cl
            Set cl = Nothing
        End If
        Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste(Split(R(l, 1), "£")(0)).Ajouter R(l, 1)
     End If
Next
i2 = Alphabet.items
 
For l = 0 To Alphabet.Count - 1
i2(l).Ecrire ThisWorkbook.Sheets("Feuil2")
Next
ThisWorkbook.Sheets("Feuil2").Cells.ColumnWidth = 48.71
ThisWorkbook.Sheets("Feuil2").Cells.EntireRow.AutoFit
ThisWorkbook.Sheets("Feuil2").Cells.EntireColumn.AutoFit
Application.EnableEvents = False
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub

[luckyalan]

Hello Rdurupt,
je vois que tu as posté une nouvelle version...Merci
la version précédente correspond bien à ma demande, alors ? ...
Quoi de neuf ? tu as modifié quoi (je ne parle pas des lignes de codes mais du rendu)...
merci

[Invité]

Je réécris le nom de l'artiste si le nombre de titres passe sur une autre page (Voir post #42)

Pour un aménagement de la première version, j'analyse la meilleure disposition pour une perte de place minimum!

[luckyalan]

Bonsoir, désolé, c'est encore moi
j'utilise ta version 2 Rdurupt qui me convient.
la version 3 est très lente et la gestion des sauts de pages ne fonctionne pas chez moi (mais ce n'est pas important la version 2 très rapide me convient.
j'ai encore un souci que j'ai essayé de regler moi meme mais je n'y arrive pas
si l'un des champs ne respecte pas la meme casse qu'un autre identique, le dictionnaire crée 2 paires.
pourtant il me semble que tu le gères ici avec le Ucase, mais cela génère quand meme 2 identités différentes

Code :

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

1
2
3
4
5
6
7
8
9
10
11
For l = 1 To R.Rows.Count
     If Dico.Exists(Split(R(l, 1), ".")(0)) = False Then
        Dico.Add Split(R(l, 1), ".")(0), Split(R(l, 1), ".")(0)
        If Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Exists(Split(R(l, 1), "£")(0)) = False Then
            Set cl = New Classe1
            Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Add Split(R(l, 1), "£")(0), cl
            Set cl = Nothing
        End If
        Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste(Split(R(l, 1), "£")(0)).Ajouter R(l, 1)
     End If
Next

je voudrais que si j'ai

Code :

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

1
2
3
4
5
6
 
Franck Alamo£Biche oh ma biche,
Franck alamo£Biche oh ma biche,
franck Alamo£Biche oh ma biche,
Franck Alamo£Biche Oh Ma Biche,
FRANCK ALAMO£BICHE OH MA BICHE,

il ne me retienne qu'une ligne (la casse de la première par défaut, ca c'est pas très important, le principal c'est qu'il n'y en ait qu'une)

et aussi si tu peux m'expliquer la modif à faire, j'aimerai comprendre (se faire aider, c'est bien, comprendre c'est encore mieux)
merci à Tous et à Rdurupt en particulier pour son aide intensive et efficace

[Invité]

Bonjour,
oui vraisemblablement, j'ai pas traité tous le Ucase!

Code Module1 :

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
Sub Etst() 'premiere boucle te fait lire la premiere colonne
Dim R As Range, cl As Classe1, Alphabet As Object, LL As Classe2
Set Alphabet = CreateObject("Scripting.Dictionary")
For l = 0 To 9
     Set LL = New Classe2
     LL.Lettre = CStr(l)
     Alphabet.Add CStr(l), LL
     Set LL = Nothing
Next
 
For l = 0 To 25
     Set LL = New Classe2
     LL.Lettre = Chr(65 + l)
     Alphabet.Add Chr(65 + l), LL
     Set LL = Nothing
Next
Dim DicoArtiste As Object
 Set DicoArtiste = CreateObject("Scripting.Dictionary")
Set R = ThisWorkbook.Sheets("Feuil1").UsedRange
'With ThisWorkbook.Sheets("Feuil1").Sort
'        .SetRange Range(R.Address)
'        .Header = xlNo
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With
Set Dico = CreateObject("Scripting.Dictionary")
For l = 1 To R.Rows.Count
     If Dico.Exists(UCase(Split(R(l, 1), ".")(0))) = False Then
        Dico.Add UCase(Split(R(l, 1), ".")(0)), UCase(Split(R(l, 1), ".")(0))
        If Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Exists(Split(R(l, 1), "£")(0)) = False Then
            Set cl = New Classe1
            Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Add UCase(Split(R(l, 1), "£")(0)), cl
            Set cl = Nothing
        End If
        Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste(UCase(Split(R(l, 1), "£")(0))).Ajouter UCase(R(l, 1))
     End If
Next
i2 = Alphabet.items
For l = 0 To Alphabet.Count - 1
i2(l).Ecrire ThisWorkbook.Sheets("Feuil2")
Next
ThisWorkbook.Sheets("Feuil2").Cells.ColumnWidth = 48.71
ThisWorkbook.Sheets("Feuil2").Cells.EntireRow.AutoFit
ThisWorkbook.Sheets("Feuil2").Cells.EntireColumn.AutoFit
End Sub

[luckyalan]

Bonjour rdurupt
avec cette modif, à la premiere occurence existante sur le nom de l'artiste, j'ai erreur 457 sur cette ligne

Code :

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

Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Add UCase(Split(R(l, 1), "£")(0)), cl

[Invité]

même problème, on va y arriver!

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
Sub Etst() 'premiere boucle te fait lire la premiere colonne
Dim R As Range, cl As Classe1, Alphabet As Object, LL As Classe2
Set Alphabet = CreateObject("Scripting.Dictionary")
For l = 0 To 9
     Set LL = New Classe2
     LL.Lettre = CStr(l)
     Alphabet.Add CStr(l), LL
     Set LL = Nothing
Next
 
For l = 0 To 25
     Set LL = New Classe2
     LL.Lettre = Chr(65 + l)
     Alphabet.Add Chr(65 + l), LL
     Set LL = Nothing
Next
Dim DicoArtiste As Object
 Set DicoArtiste = CreateObject("Scripting.Dictionary")
Set R = ThisWorkbook.Sheets("Feuil1").UsedRange
'With ThisWorkbook.Sheets("Feuil1").Sort
'        .SetRange Range(R.Address)
'        .Header = xlNo
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With
Set Dico = CreateObject("Scripting.Dictionary")
For l = 1 To R.Rows.Count
     If Dico.Exists(UCase(Split(R(l, 1), ".")(0))) = False Then
        Dico.Add UCase(Split(R(l, 1), ".")(0)), UCase(Split(R(l, 1), ".")(0))
        If Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Exists(UCase(Split(R(l, 1), "£")(0))) = False Then
            Set cl = New Classe1
            Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste.Add UCase(Split(R(l, 1), "£")(0)), cl
            Set cl = Nothing
        End If
        Alphabet(UCase(Left(Trim(R(l, 1)), 1))).DicoArtiste(UCase(Split(R(l, 1), "£")(0))).Ajouter UCase(R(l, 1))
     End If
Next
i2 = Alphabet.items
For l = 0 To Alphabet.Count - 1
i2(l).Ecrire ThisWorkbook.Sheets("Feuil2")
Next
ThisWorkbook.Sheets("Feuil2").Cells.ColumnWidth = 48.71
ThisWorkbook.Sheets("Feuil2").Cells.EntireRow.AutoFit
ThisWorkbook.Sheets("Feuil2").Cells.EntireColumn.AutoFit
End Sub

[luckyalan]

merci beaucoup ca marche,
evidemment cela me mets tout mon catalogue en majuscules mais tout compte fait c'est pas plus mal car au moins c'est lisible.
merci encore pour ta patience et ton dévouement

[luckyalan]

sur la feuille 3 j'ai fait une copie de la feuille 2 avec la fonction NOMPROPRE et comme ca j'ai le choix entre catalogue majuscule (plus lisible) ou minuscule avec initiale en majuscule (plus agréable)
voilà, avec ca mon catalogue est parfait
un IMMENSE remerciement à RDURUPT et à tous
j'ai EXACTEMENT ce que je voulais
merci merci merci

[luckyalan]

Bonjour,
encore un souci que je n'avais pas vu
losqu'un artiste a un nombre impair de titres reels, la version 2 n'affiche que le nombre pair, le dernier titre est perdu.
Ca c'est très embetant.
merci

	Vous oubliez votre cheval	Vous qui passez sans me voir
Charlie & Lulu	Ho hisse	Le feu ca brule
Charlots	La reine des paupiettes	Si tous les hippies

Charles Trenet£Vous qui passez sans me voir£10304£M -£[4 MB]
Charles Trenet£Y'a d'la joie£10305£M -£[2 MB]
Charlie & Lulu£Ho hisse£[2 MB]
Charlie & Lulu£Ho hisse£[8 KB]
Charlie & Lulu£Le feu ca brule£[2 MB]
Charlie & Lulu£Le feu ca brule£[3 KB]
Charlie & Lulu£Les Marseillais£[3 MB]
Charlie & Lulu£Les Marseillais£[8 KB]
Charlots£La reine des paupiettes£20084£M -£[23 MB]
Charlots£Si tous les hippies£20085£M -£[22 MB]

Charlie & Lulu£Les Marseillais est passé à la trappe

merci de ton aide

[luckyalan]

Bonjour,
j'essaie de me former en modifiant le code de "patricktoulon" en page 2 de ce post et qui a le mérite d'être simple, mais je je ne comprends pas complètement.

Code :

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

1
2
 
If Not dicochanson.exists(Split(tablo(i, 1), "£")(0)) Then dicochanson(Split(tablo(i, 1), "£")(0)) = ""

dans cette ligne donc je n'arrive pas à comprendre à quoi correspond (0)
merci de votre aide

[patricktoulon]

bonjour
et bien c'est simple

quand on fait un split par un ou une série de caractères ,l'element 0 est ce qui se trouve devant le premier argument du split
example

Code :

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

1
2
3
4
texte="toto£titi£robert£paul"
 
msgbox split(texte,"£")(0)' t'affichera "toto"
msgbox split(texte,"£")(2)' t'affichera "robert"

pigé?~~

[patricktoulon]

re
voila 2 exemple
le 1er sur une colonne

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
Sub test()
    Dim tablo, dicochanson, lig, NBSONG, a, elem
    Set dicochanson = CreateObject("Scripting.Dictionary")
    tablo = Sheets(1).Range("A1:A" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
    For i = 1 To UBound(tablo)
        If Not dicochanson.exists(Split(tablo(i, 1), "£")(0)) Then dicochanson(Split(tablo(i, 1), "£")(0)) = ""
        If Not dicochanson(Split(tablo(i, 1), "£")(0)) Like "*" & Split(tablo(i, 1), "£")(1) & "*" Then dicochanson(Split(tablo(i, 1), "£")(0)) = dicochanson(Split(tablo(i, 1), "£")(0)) & " | " & Split(tablo(i, 1), "£")(1)
    Next
nextlettre = ""
    For Each elem In dicochanson
        With Sheets(2)
            lig = lig + 1
           .Cells(lig, 2) = elem
           If Left(elem, 1) <> nextlettre Then
           With .Cells(lig, 1): .Value = Left(elem, 1): .Font.Bold = True: .Interior.Color = vbGreen: End With
           nextlettre = Left(elem, 1)
            End If
            NBSONG = Split(dicochanson(elem), " | ")
            With .Cells(lig, 2): .Interior.ColorIndex = 46: .Font.Bold = True: End With
 
            For a = 1 To UBound(NBSONG)
                 lig = lig + 1: .Cells(lig, 2) = NBSONG(a)
            Next
        End With
        Debug.Print elem & "::" & dicochanson(elem)
    Next
End Sub

le résultat est celui que j'ai montrer précédemment


et le 2 Emme exemple sur 3 colonne + la colonne des lettre d'indice (colonne A) comme tu le souhaite avec toujours la meme sub un peu modifiée

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
Sub test_4_colonne()
    Sheets(2).Range("A1:F" & Rows.Count).Clear
    Dim tablo, dicochanson, lig, NBSONG, a, elem, tablochanson
    Set dicochanson = CreateObject("Scripting.Dictionary")
    tablo = Sheets(1).Range("A1:A" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
    For i = 1 To UBound(tablo)
        If Not dicochanson.exists(Split(tablo(i, 1), "£")(0)) Then dicochanson(Split(tablo(i, 1), "£")(0)) = ""
        If Not dicochanson(Split(tablo(i, 1), "£")(0)) Like "*" & Split(tablo(i, 1), "£")(1) & "*" Then dicochanson(Split(tablo(i, 1), "£")(0)) = dicochanson(Split(tablo(i, 1), "£")(0)) & " | " & Split(tablo(i, 1), "£")(1)
    Next
    nextlettre = ""
    For Each elem In dicochanson
        With Sheets(2)
            lig = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 2
            .Cells(lig, 2) = elem
            If Left(elem, 1) <> nextlettre Then
                With .Cells(lig, 1): .Value = Left(elem, 1): .Font.Bold = True: .Interior.Color = vbGreen: End With
                nextlettre = Left(elem, 1)
            End If
            NBSONG = Split(dicochanson(elem), " | ")
            With .Cells(lig, 2): .Interior.ColorIndex = 46: .Font.Bold = True: End With
            ReDim tablochanson(200, 2)
            For a = 1 To UBound(NBSONG)
                place = False
                For tlig = 0 To UBound(tablochanson)
                    For tcol = 0 To 1
                        If tablochanson(tlig, tcol) = "" Then tablochanson(tlig, tcol) = NBSONG(a): place = True: Exit For
                    Next
                    If place = True Then Exit For
                Next
            Next
            .Cells(lig, 3).Resize(200, 2) = tablochanson
            .Columns("A:D").AutoFit
        End With
        Debug.Print elem & "::" & dicochanson(elem)
    Next
End Sub

résultat:

[luckyalan]

bonjour
et bien c'est simple

quand on fait un split par un ou une série de caractères ,l'element 0 est ce qui se trouve devant le premier argument du split
example

Code :

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

1
2
3
4
texte="toto£titi£robert£paul"
 
msgbox split(texte,"£")(0)' t'affichera "toto"
msgbox split(texte,"£")(2)' t'affichera "robert"

pigé?~~

Merci patrick,
evidemment, expliqué comme ca c'est tout simple... j'ai compris.
Attends toi a d'autres questions sur d'autres parties de ton code, car j'en profite pour apprendre...

[patricktoulon]

re
a tu regardé mes deux propositions dans le post 56?

[luckyalan]

Hello Patrick,
tu fais bien de m'en parler car je n'avais pas vu.
c'est génial, ca répond à ma demande, aucun défaut et du premier coup...
je vais m'amuser à regarder comment tu as fait,
c'est tout simplement super !
merci beaucoup

[patricktoulon]

pas de soucis ,si tu veux plus d'explication je suis la