XL 2019 Séparer un fichier en différents onglets alpha

[JohnBill]

Bonsoir à tout le forum.
Tous les jours, je consulte le site à la recherche d'une info qui me permettra peut être un jour de faire avancer un projet et après avoir consulté un fil sur la découpe de fichier excel, je me pose une question quelque peu similaire au fil sur la découpe en fichiers de 1000 ligne (https://www.excel-downloads.com/thr...r-excel-en-plusieurs-de-1000-lignes.20020451/). Serait il possible de faire la même chose, mais au lieu de le séparer par nombre, créer un onglet (ou fichier) par ordre alphabétique (onglet ou fichier) lettre A, (onglet ou fichier) lettre B, etc en fonction de la première lettre des infos de la deuxième colonne.
NB : si on opte pour la création de plusieurs fichiers qu'ils soient dans le répertoire du fichier source.
Je joint un exemple de fichier.

 

[sylvanu]

Bonjour JohnBill,
Un essai en PJ avec :

Sub Range()
Application.ScreenUpdating = False
DerLig = Sheets("Liste").Range("A65500").End(xlUp).Row
tablo = Sheets("Liste").Range("A1:E" & DerLig)
    For L = 1 To UBound(tablo)
        Lettre = Left(tablo(L, 2), 1)
        If IsNumeric(Lettre) Then Lettre = "0-9"
        DLDest = 1 + Sheets(Lettre).Range("A65500").End(xlUp).Row
        If Application.CountIf(Sheets(Lettre).Range("C1:C" & DLDest), tablo(L, 3)) = 0 Then
            For i = 1 To 5
                Sheets(Lettre).Cells(DLDest, i) = tablo(L, i)
            Next i
        End If
        Application.StatusBar = "Progression : " & Format(L / DerLig, "0%")
    Next L
Application.StatusBar = ""
End Sub

( J'ai passé le fichier en xlsb pour être sous le 1Mo fatidique pour les pièces jointes. Si vous le voulez en xlsm alors ouvrez et enregistrez sous xlsm. Le xlsb est identique mais pas exploitable sur tablette au niveau de la macro )

 

[sylvanu]

La V1 pose un problème. Si vous rajoutez un disque il ne sera pas rangé par liste alpha comme dans Liste mais à la fin.
En V2 c'est rectifié. En fait j'efface tout et je reconstruit.

 

[JohnBill]

Super. Tout fonctionne même en rajoutant des éléments. Quand je pense que je faisait pareil à la main avec du copier/coller. Un gros merci et une dernière question : Comme j'ai plus de 65500 lignes, je pense qu'il me suffit de le modifier dans la macro à la valeur DerLig ?

 

[sylvanu]

Oui par 1048575 ... ce qui vous laisse de la marge.

 

[JohnBill]

Nickel. Encore un gros merci.

 

[job75]

Bonsoir JohnBill, sylvanu,

Avec le filtre avancé c'est plus rapide, voyez le fichier .xlsm joint et cette macro :

Sub Ventiler()
Dim t#, Nsource&, i%, n&
t = Timer
Application.ScreenUpdating = False
With [A1].CurrentRegion
    Nsource = .Rows.Count - 1
    For i = 2 To 28
        Sheets(i).Cells.Delete 'RAZ
        [G2] = IIf(i = 2, "=ISNUMBER(-LEFT(B2))", "=LEFT(B2)=""" & Chr(62 + i) & """") 'critère
        .AdvancedFilter xlFilterCopy, [G1:G2], Sheets(i).Cells(1) 'filtre avancé
        n = n + Sheets(i).Cells(1).CurrentRegion.Rows.Count - 1 'comptage des lignes
    Next
End With
[G2] = ""
MsgBox n & " lignes sur " & Nsource & " ont été ventilées en " & Format(Timer - t, "0.00 \sec")
End Sub

A+

 

[job75]

Bonjour le fil, le forum,

Si l'on veut ventiler dans des fichiers séparés on utilisera :

Sub Ventiler()
Dim t#, chemin$, Nsource&, i%, n&, nomfich$
t = Timer
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si les fichiers existent déjà
Workbooks.Add xlWBATWorksheet 'document auxiliaire vierge
With Feuil1.[A1].CurrentRegion 'CodeName de la feuille
    Nsource = .Rows.Count - 1
    For i = 2 To 28
        .Cells(2, 7) = IIf(i = 2, "=ISNUMBER(-LEFT(B2))", "=LEFT(B2)=""" & Chr(62 + i) & """") 'critère
        .AdvancedFilter xlFilterCopy, .Cells(1, 7).Resize(2), Cells(1) 'filtre avancé
        n = n + Cells(1).CurrentRegion.Rows.Count - 1 'comptage des lignes
        nomfich = IIf(i = 2, "0-9", Chr(62 + i))
        ActiveSheet.Name = nomfich 'renomme la feuille
        On Error Resume Next: Workbooks(nomfich & ".xlsx").Close: On Error GoTo 0 'si le fichier est ouvert
        ActiveWorkbook.SaveAs chemin & nomfich, 51 'enregistrement au format .xlsx
        Cells.Clear 'RAZ
    Next
    .Cells(2, 7) = ""
End With
ActiveWorkbook.Close 'ferme le document auxiliaire
MsgBox n & " lignes sur " & Nsource & " ont été ventilées en " & Format(Timer - t, "0.00 \sec")
End Sub

Placez le fichier joint dans un dossier spécifique avant de lancer la macro.

A+

 

[JohnBill]

Merci à tous deux. Les deux nouvelles versions fonctionnent nickel comme la première et plus rapidement sur le filtre avancé.
Cela m'ouvre des perspectives différentes en fonction de mes besoins.
Je vais tester sur mon vrai fichier qui comporte plus de 500000 lignes.

 

[sylvanu]

500000 lignes ? Vous êtes disquaire ?

 

[job75]

Je vais tester sur mon vrai fichier qui comporte plus de 500000 lignes.

Pour tester c'est facile, copier la plage A2:E19817 sur A2:E515217, on obtient un fichier de 13,7 Mo..

La macro du fichier (1) post #7 s'exécute chez moi en 23 secondes.

La macro du fichier (2) post #8 s'exécute en 30 secondes.