Macro découpage tableau en plusieurs onglets
Bonjour,
Veuillez trouver ci-joint un tableau que je souhaite découper en plusieurs onglets selon les données de la colonne B.
Le résultats souhaité se trouve dans les 6 onglets qui suivent.
Grâce à Scraper, un intervenant du forum, j'ai déjà essayé d'utiliser la macro proposée par ce site : https://www.exceldemy.com/split-excel-sheet-into-multiple-sheets-based-on-column-value/#Method-5_VBA...
Cela fonctionne très bien quand le fichier fait quelques centaines de lignes, mais cela ne fonctionne plus lorsque le fichier fait 15 000 lignes ou plus.
Auriez-vous une macro qui pourrait permettre d'effectuer cette tâche s'il vous plaît ?
En vous remerciant par avance pour votre retour, je vous souhaite une bonne après-midi.
Bien cordialement,
Sinokisme
Bonjour,
Un essai :
Sub DecouperTable()
Dim Lig As Long, Sh As Worksheet, Val As String
Application.Calculation = xlCalculationManual
With Sheets("Feuil1") 'Nom à adapter
For Lig = 2 To .Range("B" & Rows.Count).End(xlUp).Row
Val = .Range("B" & Lig)
If F_Existe(.Range("B" & Lig)) Then
Set Sh = Sheets(Val)
Else
If Sheets.Count = 255 Then MsgBox "Nombre maximal de feuilles atteint !": GoTo Fin
Set Sh = Sheets.Add
Sh.Name = .Range("B" & Lig)
.Rows(1).Copy Sh.Rows(1)
End If
.Rows(Lig).Copy Sh.Rows(Sh.Range("B" & Rows.Count).End(xlUp).Row + 1)
Application.CutCopyMode = False
Next Lig
End With
Fin:
Application.Calculation = xlCalculationAutomatic
End Sub
Function F_Existe(ByVal NomFeuille As String) As Boolean
Dim Sh As Worksheet
For Each Sh In Sheets
If UCase(Sh.Name) = UCase(NomFeuille) Then F_Existe = True: Exit For
Next Sh
End Functionbonsoir,
11 secondes
Sub test()
t = Timer
Application.ScreenUpdating = False
With Sheets("À découper")
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> .Name Then sh.Delete 'delete toutes les feuilles <> A Decouper
Next
Application.DisplayAlerts = True
.Columns("AA").ClearContents
Set c = .Range("A14:A" & .Range("A" & Rows.Count).End(xlUp).Row) 'plage des données dans la colonne A
c.AdvancedFilter xlFilterCopy, , .Range("AA1"), 1 'les valeurs uniques
arr = .Range("AA1:AA" & .Range("AA" & Rows.Count).End(xlUp).Row).Value 'vers un array
For i = 2 To UBound(arr) 'boucle ces valeurs uniques
.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'copie de la feuille
With ActiveSheet
.Name = CStr(arr(i, 1)) 'renommer feuille
With .Range("A14").Resize(c.Rows.Count)
.AutoFilter 1, "<>" & arr(i, 1) 'filtre tous les nom <> ce valeur unique
.Offset(1).SpecialCells(xlVisible).EntireRow.Delete 'delete toutes les lignes visible
.AutoFilter '
End With
End With
Next
End With
MsgBox Timer - t
End SubBonjour Pedro22 et BsALv,
Merci pour vos réponses. Je n'arrive pas à lancer ta macro Pedro22.
BsALv, ta macro fonctionne mais elle crée des onglets à partir des critères contenus dans la première colonne (Alpha, Beta, etc...).
Or il faudrait créer les onglets selon le deuxième critères (001, 002, etc...).
J'ai essayé de remplacer dans ton code A par B mais cela ne fonctionne pas (message d'erreur et débogage) :
Sub test()
t = Timer
Application.ScreenUpdating = False
With Sheets("À découper")
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> .Name Then sh.Delete 'delete toutes les feuilles <> A Decouper
Next
Application.DisplayAlerts = True
.Columns("BB").ClearContents
Set c = .Range("B14:B" & .Range("B" & Rows.Count).End(xlUp).Row) 'plage des données dans la colonne A
c.AdvancedFilter xlFilterCopy, , .Range("BB1"), 1 'les valeurs uniques
arr = .Range("BB1:BB" & .Range("B" & Rows.Count).End(xlUp).Row).Value 'vers un array
For i = 2 To UBound(arr) 'boucle ces valeurs uniques
.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'copie de la feuille
With ActiveSheet
.Name = CStr(arr(i, 1)) 'renommer feuille
With .Range("B14").Resize(c.Rows.Count)
.AutoFilter 1, "<>" & arr(i, 1) 'filtre tous les nom <> ce valeur unique
.Offset(1).SpecialCells(xlVisible).EntireRow.Delete 'delete toutes les lignes visible
.AutoFilter '
End With
End With
Next
End With
MsgBox Timer - t
End SubJ'ai dû faire une erreur quelque part.
En vous remerciant par avance, je vous souhaite une bonne journée.
Bien à vous,
Sinokisme
re,
c'était different parce que 1) il faut eviter les valeurs vide ("") et 2) quand la macro voulait filtrer sur "<>001", excel traduisait cela en "<>1".
Donc il y a des petites choses qui sont changées.
Sub test()
t = Timer 'start chronometer
Application.ScreenUpdating = False
With Sheets("À découper")
Application.DisplayAlerts = False 'ne demande pas des questions
For Each sh In ThisWorkbook.Worksheets 'boucle les feuilles
If sh.Name <> .Name Then sh.Delete 'delete toutes les feuilles <> A Decouper
Next
Application.DisplayAlerts = True
.Columns("BB").ClearContents 'affacer colonne auxiliaire
Set c = .Range("B14:B" & .Range("B" & Rows.Count).End(xlUp).Row) 'plage des données dans la colonne B
c.AdvancedFilter xlFilterCopy, , .Range("BB1"), 1 'les valeurs uniques de cette plage
arr = Application.Transpose(.Range("BB2:BB" & .Range("B" & Rows.Count).End(xlUp).Row).Value) 'ces valeurs sauf l'entête, vers un array
For i = 1 To UBound(arr) 'boucle ces valeurs uniques
If Len(arr(i)) > 0 Then ' ne pas des valeurs vides
.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'copie de la feuille
With ActiveSheet 'la nouvelle feuille
.Name = CStr(arr(i)) 'renommer feuille
Set c1 = .Range("B14").Resize(c.Rows.Count) 'la plage + entête de la colonne B
c1.AutoFilter 1, Filter(arr, arr(i), 0, 1), xlFilterValues 'filtre tous les nom <> ce valeur unique
c1.Offset(1).SpecialCells(xlVisible).EntireRow.Delete 'delete toutes les lignes visible
c1.AutoFilter '
End With
End If
Next
End With
MsgBox Timer - t
End SubBonjour BsAlv,
Désolé pour ma réponse tardive. Ta macro fonctionne parfaitement.
Merci beaucoup !
Bonne journée
Sinokisme