Microsoft 365 Garder la mise en forme après une action d'une macro

[bobjazz]

Bonjour le Forum
La macro que j'utilise me sert à créer des nouveaux classeurs en fonction d'une donnée en colonne A, cela fonctionne très bien, mais je ne garde pas la mise en forme du tableau d'origine;
Joint un fichier pour l'exemple et joint le code.

Sub Macro1Onglet()
Dim dl As Long
Dim pl As Range
Dim d As Object
Dim cel As Range
Dim tp As Variant
Dim i As Integer
Dim o As Object

With Sheets("Eclairage normal")
dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
Set pl = .Range("A1:A" & dl)
End With
Set d = CreateObject("Scripting.Dictionary")
For Each cel In pl
d(cel.Value) = ""
Next cel
tp = d.keys
For i = 0 To UBound(tp)
On Error Resume Next
Set o = Sheets(CStr(tp(i)))
If Err <> 0 Then
Err = 0
Sheets.Add Before:=Sheets(1)
Set o = ActiveSheet
o.Name = CStr(tp(i))
End If
On Error GoTo 0
o.Cells.Clear
Sheets("Eclairage normal").Range("A1").AutoFilter
Sheets("Eclairage normal").Range("A1").AutoFilter Field:=1, Criteria1:=tp(i)
pl.Offset(0, 1).Resize(pl.Rows.Count, 20).SpecialCells(xlCellTypeVisible).Copy o.Range("A1")
Sheets("Eclairage normal").Range("A1").AutoFilter
Next i
End Sub

Merci de votre aide

Bobjazz

 

[Dranreb]

Bonjour.
Ajoutez à peu près ça dans votre boucle :

    With o.ListObjects.Add(xlSrcRange, o.UsedRange, , xlYes)
      .Name = "Tab" & Replace(o.Name, " ", "")
      .TableStyle = "TableStyleMedium6"
      End With

 

[bobjazz]

Bonjour Dranreb
j'ai rajouté dans la boucle et je garde bien la mise en forme hauteur et largeur, mais je voudrais garder le mode tableau.
Tu crois que c'est possible
Merci

Bobjazz

 

[Dranreb]

Mais ça ajoute bien un tableau justement !

 

[bobjazz]

oui mais j'aurai voulu garder le principe de couleurs différentes dans les onglets créés si c'était possible.
Merci de ton aide
Bobjazz

 

[Dranreb]

Vous les avez bien mis à la fin, au moins, une fois que la o.UsedRange a été garnie ?

 

[bobjazz]

Voici où je l'ai mis
With Sheets("Eclairage normal")
dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row
Set pl = .Range("A1:A" & dl)
End With
Set d = CreateObject("Scripting.Dictionary")
For Each cel In pl
d(cel.Value) = ""
Next cel
tp = d.keys
For i = 0 To UBound(tp)
On Error Resume Next
Set o = Sheets(CStr(tp(i)))
If Err <> 0 Then
Err = 0
Sheets.Add Before:=Sheets(1)
Set o = ActiveSheet
o.Name = CStr(tp(i))
End If
On Error GoTo 0
o.Cells.Clear
Sheets("Eclairage normal").Range("A1").AutoFilter
Sheets("Eclairage normal").Range("A1").AutoFilter Field:=1, Criteria1:=tp(i)
pl.Offset(0, 1).Resize(pl.Rows.Count, 20).SpecialCells(xlCellTypeVisible).Copy o.Range("A1")
Sheets("Eclairage normal").Range("A1").AutoFilter
Next i
With o.ListObjects.Add(xlSrcRange, o.UsedRange, , xlYes)
.Name = "Tab" & Replace(o.Name, " ", "")
.TableStyle = "TableStyleMedium6"
End With
End Sub

Merci
Bobjazz

 

[Dranreb]

Ben non, c'est avant la Next i qu'il faut le mettre pour que ce soit fait sur chaque feuille créée !

 

[bobjazz]

Mis au bonne endroit nickel
Encore merci
Je me permet de te demander si c'est possible, voici le fichier que je travaille.
J'ai 3 onglets différents qui ont une valeur commune la colonne A
J'ai trouvé un code que j'ai adapté, d'abords je crée des onglets avec le code que tu viens de m'adapter et après avec le deuxième code je crée des fichiers avec les onglets différents.
Je cherche sur la toile mais je n'ai pas encore trouvé, je bloque mon but et de créer des fichiers avec les 3 onglets par site (colonne A).
Dans ma méthode cela crée 200 onglets fois 3 donc 600 fichiers que je doit retravailler en déplacent les onglets pour arriver à mon résultat fichier "Site 1".
J'ai mis les fichiers qui expliqueront surement mieux que moi
Merci
Bobjazz