XL 2016 Liste diviser onglet

[Djidji]

Bonjour,

Pour vous expliquer simplement, j'ai un fichier global que je souhaiterai diviser en plusieurs onglets triés en fonction de la valeur de la première cellule des lignes.

Exemple:
Fichier effectif global avec affectation en colonne A
Je souhaiterai que mon fichier soit diviser en affectation, une affectation = un onglet.

J'ai trouvé une macro qui permettait de faire ce travail, mais elle ne prend pas en compte le format et la mise en forme de mes cellules.

Je débute en vba et je ne maitrise pas encore les collections bibliothèques.

Je remercie énormément tous ceux qui auront bien voulu m'aider.

Voici la macro (que je n'arrive pas à retravailler du tout):

'NOMMER LA FEUILLE D'ORIGINE "Données"
'LA LISTE COMMENCE EN A2

Sub Balaye()

Dim NoDupes As New Collection
'Application.ScreenUpdating = False

A = Range([A2], [A65536].End(xlUp)).Value

On Error Resume Next

' Boucle pour récupérer la collection d'items uniques

For J = 1 To UBound(A, 1)
NoDupes.Add A(J, 1), CStr(A(J, 1))
Next J

' Réactivation du gestionnaire d'erreurs
On Error GoTo 0
Range("A1").CurrentRegion.Select
With Selection.CurrentRegion
Intersect(.Cells, .Offset(1)).Select
End With

B = Selection.Value

NbCol = Selection.Columns.Count
[A1].Select
ReDim Tableau(1 To UBound(B), 1 To NbCol)
For k = 1 To UBound(B, 1)
For Z = 1 To NbCol
Tableau(k, Z) = B(k, Z)
Next Z
Next k

H = 1

For I = 1 To NoDupes.Count
Sheets.Add after:=Sheets(I)
ActiveSheet.Name = NoDupes(I)
For x = 1 To UBound(A, 1)
If Tableau(x, 1) = NoDupes(I) Then
For w = 1 To NbCol
Cells(H + 1, w).Value = Tableau(x, w)
Next w
H = H + 1
Else
End If
Next x
H = 1
Next I

Sheets("Données").Activate

NbSheet = ActiveWorkbook.Sheets.Count
Range([A1], [IV1].End(xlToLeft)).Select
Set MaPlage = Selection
[A1].Select
For NS = 2 To NbSheet
Set Destination = ActiveWorkbook.Sheets(NS).Range("A1")
MaPlage.Copy Destination
Next NS
'Application.ScreenUpdating = True

End Sub

 

[Corentin.PL]

Je t'invites, dans un soucis de simplification de lecture, à utiliser les BBCodes (en l'occurence : les trois petits points avec une fleche de menu déroulant, typologie "</> Code".
Ceci te permet d’afficher comme ci-dessous :

'NOMMER LA FEUILLE D'ORIGINE "Données"
'LA LISTE COMMENCE EN A2

Sub Balaye()

Dim NoDupes As New Collection
'Application.ScreenUpdating = False

A = Range([A2], [A65536].End(xlUp)).Value

On Error Resume Next

' Boucle pour récupérer la collection d'items uniques

For J = 1 To UBound(A, 1)
NoDupes.Add A(J, 1), CStr(A(J, 1))
Next J

' Réactivation du gestionnaire d'erreurs
On Error GoTo 0
Range("A1").CurrentRegion.Select
With Selection.CurrentRegion
Intersect(.Cells, .Offset(1)).Select
End With

B = Selection.Value

NbCol = Selection.Columns.Count
[A1].Select
ReDim Tableau(1 To UBound(B), 1 To NbCol)
For k = 1 To UBound(B, 1)
For Z = 1 To NbCol
Tableau(k, Z) = B(k, Z)
Next Z
Next k

H = 1

For I = 1 To NoDupes.Count
Sheets.Add after:=Sheets(I)
ActiveSheet.Name = NoDupes(I)
For x = 1 To UBound(A, 1)
If Tableau(x, 1) = NoDupes(I) Then
For w = 1 To NbCol
Cells(H + 1, w).Value = Tableau(x, w)
Next w
H = H + 1
Else
End If
Next x
H = 1
Next I

Sheets("Données").Activate

NbSheet = ActiveWorkbook.Sheets.Count
Range([A1], [IV1].End(xlToLeft)).Select
Set MaPlage = Selection
[A1].Select
For NS = 2 To NbSheet
Set Destination = ActiveWorkbook.Sheets(NS).Range("A1")
MaPlage.Copy Destination
Next NS
'Application.ScreenUpdating = True

End Sub

 

[job75]

Bonjour Djidji, Corentin.PL,

Plutôt qu'une Collection il vaut mieux utiliser le Dictionary pour obtenir une liste sans doublon, c'est plus rapide.

A+

 

[job75]

Voici une macro qui utilise le Dictionary et le filtre automatique (pour que les formats soient conservés) :

Sub CreerFeuilles()
Dim F As Worksheet, s As Object, tablo, d As Object, i&, a
Set F = Worksheets("Données") 'nom à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next 's'il y a des caractères interdits
'---suppression des feuilles existantes---
For Each s In Sheets
    If s.Name <> F.Name Then s.Delete
Next s
'---liste sans doublon des feuilles à créer---
tablo = F.UsedRange.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
    If tablo(i, 1) <> "" Then d(Left(tablo(i, 1), 31)) = ""
Next i
If d.Count = 0 Then Exit Sub
'---création des feuilles---
a = d.keys
With F.UsedRange
    For i = 0 To UBound(a)
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = a(i)
        If ActiveSheet.Name <> a(i) Then MsgBox "Caractère interdit dans '" & a(i) & "' !", 48
        .AutoFilter 1, a(i) & IIf(Len(a(i)) = 31, "*", "") 'filtre automatique
        .Copy ActiveSheet.Cells(1)
    Next i
End With
F.AutoFilterMode = False 'retire le filtre
F.Activate
End Sub

 

[Djidji]

Bonjour corentin, bonjour job,

Un très grand merci pour vos réponses!! Je vais les tester ce matin et étudier tout ça!!
Vous êtes super forts!

Je vous dirais si cela a bien fonctionné

 

[Djidji]

Alors! elle fonctionne bien mieux que la première que j'ai trouvé (elle est bien plus rapide). Elle ne prend malheureusement toujours pas en compte les formats et mise en forme.

Je vais essayer de la "corriger" par moi même, mais si vous avez des suggestions (car je ne maitrise pas encore bien les collections/bibliothèque en vba), je suis fort à l'écoute.
Merci beaucoup,

Djidji

 

[job75]

Elle ne prend malheureusement toujours pas en compte les formats et mise en forme.

Ne racontez pas n'importe quoi, j'ai bien dit qu'avec le filtre automatique les formats sont conservés, voyez le fichier joint.

 

[Djidji]

Pour moi elle fonctionne également sans filtre dans votre fichier. (ou alors nous ne parlons pas de la même chose, j'entends par filtres automatiques les flèches permettant de trier les données des colonnes).

Une fois intégrée dans mon fichier, elle ne sélectionne pas les cellules ayant une mise en forme (premier essaie avec filtre et second sans filtre). C'est comme si je faisais une copie d'une colonne filtrée sans mise en forme.

La solution que vous m'avez donnée est parfaite, je dois juste l'adapter à mon fichier et bien comprendre son fonctionnement. D'ailleurs, c'est la première fois que je vois l'utilisation de l'objet dictionary. Ce qui est fort interessant.

Encore une fois, merci beaucoup

 

[job75]

Si l'on veut aussi copier les hauteurs des lignes et largeurs des colonnes voyez ce fichier (2) et le code :

With F.UsedRange
    ncol = .Columns.Count
    For i = 0 To UBound(a)
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = a(i)
        If ActiveSheet.Name <> a(i) Then MsgBox "Caractère interdit dans '" & a(i) & "' !", 48
        .AutoFilter 1, a(i) & IIf(Len(a(i)) = 31, "*", "") 'filtre automatique
        .EntireRow.Copy ActiveSheet.Cells(1) 'copie les lignes entières pour copier les hauteurs
        .Cells(1).Copy .Cells(1) 'pour alléger la mémoire
        ActiveSheet.DrawingObjects.Delete 'supprime le bouton
        For j = 1 To ncol
            ActiveSheet.Columns(j).ColumnWidth = .Columns(j).ColumnWidth 'copie les largeurs des colonnes
    Next j, i
End With

 

[Djidji]

Vous êtes trop gentil

Je pense que j'ai un soucis avec mes filtres. J'intègre votre macro à une giga maro qui calcule, met en page et enregistre une cinquantaine de tableaux.
La macro précédente présente un bug lorsque j'essaie de trier mes colonnes de a à z, j'avais réussi à détourner le pb mais je pense que c'est toujours la et que cela influence la suite des évènements.

Voici la partie de macro buguée (ou du moins que j'ai mal enregistrée ou écrite):
<
ActiveWorkbook.Worksheets("Données").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Données").AutoFilter.Sort.SortFields.Add Key:=Range("H1:H3763"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Données").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With>

Apparament je n'aurais pas bien définis mes objets (erreur variable bloc with non défini). Je n'utilise jamais les bloc with end with sauf quand j'enregistre automatiquement mes macros.

L'erreur est peu être évidente mais je ne la voie pas. En tout cas j'épluche les forums pour voir les possible erreurs liées au bloc with (j'ai essayé de mettre mes objets sheets/range en variable pour ensuite les appelés mais cela ne fonctionne pas, sachant que si je déclare worksheets = worksheets("Données") et bien c'est bizarre et cela ne fonctionne pas non plus. J'ai également essayé de mettre l'index de la feuille au lieu du nom mais l’erreur persiste).

De plus, j'ai suis sur excel 2010(même si je doute que cela soit le pb) aujourd'hui.

Encore une mille merci pour votre aide,

 

[job75]

J'intègre votre macro à une giga maro qui calcule, met en page et enregistre une cinquantaine de tableaux.

Si c'est vous qui avez pondu la giga macro vous devez être capable de vous débrouiller sinon demandez à l'auteur.

 

[Djidji]

Oui exactement! Je vais bien finir par trouver! C'est comme ça qu'on apprends!

En tout cas merci beaucoup pour votre macro elle est vraiment top

 

[Djidji]

Bonjour Job,

J'ai réussi!
La ligne suivante était en trop dans mon fichier:
.AutoFilter 1, a(i) & IIf(Len(a(i)) = 31, "*", "")

Ma "giga macro" fonctionne presque parfaitement.

Un très très très grand merci!!!

 

[job75]

Bah si vous enlevez cette ligne ma macro ne filtrera rien du tout !