[VBA] Transfert vers plusieurs onglet

Sub AJOUTER()
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")

For Each f In Worksheets
    If f.Name <> ActiveSheet.Name Then
        dico(f.Name) = ""
        With f.Tab
            .ColorIndex = xlNone
            .TintAndShade = 0
        End With
    End If
Next

Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion
nbcol = plage.Columns.Count
For i = 1 To plage.Rows.Count

    ' cas d'une année
    Set obj = CreateObject("vbscript.regexp")
    obj.Pattern = "[0-9]{4}"
    txt = plage.Cells(i, 1).Value
    Set annee = obj.Execute(txt)
    If annee.Count > 0 Then
        onglet = CStr(annee(0))
        If dico.exists(onglet) Then
            With Sheets(onglet)
                plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                With .Sort
                    .SetRange Sheets(onglet).Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                With .Tab
                    .Color = 49407
                    .TintAndShade = 0
                End With
            End With
            plage.Cells(i, 1).Value = Replace(plage.Cells(i, 1).Value, annee(0) & " - ", "")
        End If
    End If

    ' cas d'un nom
        onglet = Split(plage.Cells(i, 1).Value & " ", " ")(0)
        If dico.exists(onglet) Then
            With Sheets(onglet)
                plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                With .Sort
                    .SetRange Sheets(onglet).Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                With .Tab
                    .Color = 49407
                    .TintAndShade = 0
                End With
            End With

        End If

Next

End Sub

Non ça marche pas,

il me met toujours l'année quand j’appuie sur ajouter

il y a aussi, quand je rentre des albums pour Fun et Skyrock et qu'il y a une année dedans il me la transfère dans l'année et non dans fun ou Skyrock

Par contre pour NRJ ça marche bien

willy95 a écrit :

il y a aussi, quand je rentre des albums pour Fun et Skyrock et qu'il y a une année dedans il me la transfère dans l'année et non dans fun ou Skyrock

parce que je ne prend que le premier terme comme les exemples cités ici

willy95 a écrit :

- NRJ Superqstarts : l'ajouter des qu'il y a NRJ dans l'onglet "NRJ" tel quel.

- SKYROCK HITS 2020 : l'ajouter des qu'il y a SKYROCK dans l'onglet "SKYROCK" tel quel.

- FUN DANCE 2021 : l'ajouter des qu'il y a FUN dans l'onglet "FUN" tel quel.

- 2018 - les beaux artistes : l'ajouter des qu'il y a une année avec le tiret dans l'onglet "de l'année adéquat" et de le modifier "Les beaux artistes".

je vais donc balayer le titre complet

Sub AJOUTER()
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")

For Each f In Worksheets
    If f.Name <> ActiveSheet.Name Then
        dico(f.Name) = ""
        With f.Tab
            .ColorIndex = xlNone
            .TintAndShade = 0
        End With
    End If
Next

Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion
nbcol = plage.Columns.Count
For i = 1 To plage.Rows.Count

    ' cas d'une année
    Set obj = CreateObject("vbscript.regexp")
    obj.Pattern = "[0-9]{4}"
    txt = plage.Cells(i, 1).Value
    Set annee = obj.Execute(txt)
    If annee.Count > 0 Then
        onglet = CStr(annee(0))
        If dico.exists(onglet) Then
            With Sheets(onglet)
                plage.Cells(i, 1).Value = Replace(plage.Cells(i, 1).Value, annee(0) & " - ", "")
                plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                With .Sort
                    .SetRange Sheets(onglet).Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                With .Tab
                    .Color = 49407
                    .TintAndShade = 0
                End With
            End With
        End If
    End If

    ' cas d'un nom
    noms = Split(plage.Cells(i, 1).Value & " ", " ")
    For n = LBound(noms) To UBound(noms)
        onglet = noms(n)
        If dico.exists(onglet) Then
            With Sheets(onglet)
                plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                With .Sort
                    .SetRange Sheets(onglet).Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                With .Tab
                    .Color = 49407
                    .TintAndShade = 0
                End With
            End With
        End If
    Next
Next

End Sub

Alors la chapeau, on vois la maitrise,

y a juste un petit truc, mais je ferais avec, car :

quand je met 2002 - Sweet Rnb 2002 il reconnait le 2002 2 fois du coup il me met les deux mêmes lignes

En tous merci beaucoup

Bonjour,

Dis-moi en fait il y a un truc qui m'embêtes un peu dans la code

quand je rentre un albums exemple :

"NRJ Extravadance 2020" il le met à la fois dans l'onglet "NRJ" et aussi dans l'onglet "2020".

"Les Hits Skyrock 2020" par contre, il ne le met que dans l'onglet "2020" alors qu'il ne devrais que le mettre dans "SKYROCK",

"Fun Dance 2020" par contre, il ne le met que dans l'onglet "2020" alors qu'il ne devrais que le mettre dans "FUN",

Y aurait-t-il un moyen de que quand il fait un balayage des fichiers que quand il voit NRJ, FUN ou SKYROCK, il les mettent que dans ces onglets ?

Et aussi quand il fait un balayage et qu'il voit en début, exemple :

"2020 - La Bande à Renaud 2020" il ne prenne en comptes que le début c'est a dire "2020 - "

willy95 a écrit :

"Les Hits Skyrock 2020" par contre, il ne le met que dans l'onglet "2020" alors qu'il ne devrais que le mettre dans "SKYROCK",

"Fun Dance 2020" par contre, il ne le met que dans l'onglet "2020" alors qu'il ne devrais que le mettre dans "FUN",

question de majuscule/minuscule, ok je vais prendre en compte ceci

Oui ce sont les bonnes minuscules/Majuscule

willy95 a écrit :

Y aurait-t-il un moyen de que quand il fait un balayage des fichiers que quand il voit NRJ, FUN ou SKYROCK, il les mettent que dans ces onglets ?

et s'il y en a 2 ou 3 ? xemple FUN NRJ ?

Les règles que j'ai donc prises :

1. si la ligne commence par une année qui est dans les onglets, je copie dans cet onglet en enlevant la date suivie de -  et je m'arrête là pour cette ligne, pas d'autre recherche
2. si la ligne ne commence pas par une année, je découpe le texte en mots-majuscules et je stocke la ligne dans le premier mot trouvé qui est aussi un onglet, et je m'arrête là

Sub AJOUTER()
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")

For Each f In Worksheets
    If f.Name <> ActiveSheet.Name Then
        dico(UCase(f.Name)) = ""
        With f.Tab
            .ColorIndex = xlNone
            .TintAndShade = 0
        End With
    End If
Next

Set plage = Range("A" & Rows.Count).End(xlUp).CurrentRegion
nbcol = plage.Columns.Count
For i = 1 To plage.Rows.Count

    ' cas d'une année en début de titre - dans ce cas pas d'autre recherche
    If IsNumeric(Left(plage.Cells(i, 1), 4)) Then
        onglet = CStr(Left(plage.Cells(i, 1), 4))
        If dico.exists(onglet) Then
            With Sheets(onglet)
                plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                .Range("A" & Rows.Count).End(xlUp).Value = Replace(.Range("A" & Rows.Count).End(xlUp).Value, onglet & " - ", "")
                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                With .Sort
                    .SetRange Sheets(onglet).Range("A1").CurrentRegion
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                With .Tab
                    .Color = 49407
                    .TintAndShade = 0
                End With
            End With
        End If
    Else

        ' cas d'un nom = on bloque au premier nom trouvé
        noms = Split(plage.Cells(i, 1).Value & " ", " ")
        flag = True
        For n = LBound(noms) To UBound(noms)
            onglet = UCase(noms(n))
            If dico.exists(onglet) And flag Then
                flag = False
                With Sheets(onglet)
                    plage.Cells(i, 1).Resize(1, nbcol).Copy Destination:=.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                    .Sort.SortFields.Clear
                    .Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
                    With .Sort
                        .SetRange Sheets(onglet).Range("A1").CurrentRegion
                        .Header = xlNo
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                    End With
                    With .Tab
                        .Color = 49407
                        .TintAndShade = 0
                    End With
                End With
            End If
        Next

    End If
Next

End Sub

Là c'est parfait Merci beaucoup,

Je t'embêtes plus avec ce sujet

Pas de soucis si besoin ... SAV assuré !

Bonjour Steelson,

J'espère que tu vas bien, je reviens sur ton code VBA que tu m'as fait il y quelques mois, qui marchait nickel avec mon ancien fichier.

Depuis j'ai refait mon tableau que je te joins, en mettant des entêtes (faire un peu plus sérieux), est-ce que tu pourrais refaire ce que tu m'as fait précédemment sur c'est nouveau classeurs.

Je t'en remercie par avance

Willy95

Bonjour Steelson,

En fait pour mon code VBA, je sais pas si tu as commencé à le regarder, mais en fait je carrément refait mon classeur, j'ai tout rassembler dans un seul classeur, et je ne sait pas si pouvais le même code que tu m'avais fait pour classer mes albums qui sont dans "nouvel entrée" dans les différentes feuilles [0-9] et A à Z.