Boucle Macro Excel

[Julbarbo]

Bonjour à tous,

J'ai une base de données sous Excel avec notamment les noms des directions de mon entreprise.

Après avoir réussi ma macro pour extraire un onglet par direction à partir de ma base de deonnées, je m'attaque à la mise en forme de mes onglets et quand je lance ma macro, la mise en forme ne s'applique que sur le 1° des 10 onglets. C'est un problème de boucle je pense, mais je ne sais comment le résoudre.

Merci d'avance.

Si besoin, voici mon code


Option Explicit

Dim Tabtemp As Variant
Dim TabRecup() As Variant
Dim Ligne As Long
Dim Col As Byte
Dim DerCol As Byte
Dim Ws As Worksheet
Dim Col_Chef As Collection
Dim DerLigne As Long
Dim Lgn As Long
Dim x As Integer
Dim ShtName As String


Sub Test()
Columns("P").Select
Selection.Delete Shift:=xlToLeft
Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft

Application.ScreenUpdating = False
Set Col_Chef = New Collection

With Worksheets("Feuil1")
DerLigne = .Range("A65536").End(xlUp).Row
DerCol = .Range("IV1").End(xlToLeft).Column
Tabtemp = .Range(.Cells(2, 1), .Cells(DerLigne, DerCol)).Value
On Error Resume Next
For Ligne = 1 To UBound(Tabtemp, 1)
Col_Chef.Add Tabtemp(Ligne, 1), CStr(Tabtemp(Ligne, 1))
If Err.Number = 0 Then
x = -1
ShtName = Tabtemp(Ligne, 1)
For Lgn = 1 To UBound(Tabtemp, 1)
If Tabtemp(Lgn, 1) = ShtName Then
x = x + 1
ReDim Preserve TabRecup(DerCol, x)
For Col = 1 To UBound(Tabtemp, 2)
TabRecup(Col - 1, x) = Tabtemp(Lgn, Col)
Next Col
End If
Next Lgn
Set Ws = Worksheets.Add
With Ws
.Name = ShtName
Worksheets("Feuil1").Range(Worksheets("Feuil1").Cells(1, 1), Worksheets("Feuil1").Cells(1, DerCol)).Copy Destination:=.Range("A1")
DerLigne = .Range("A65536").End(xlUp).Row + 1
.Cells(DerLigne, 1).Resize(UBound(TabRecup, 2) + 1, UBound(TabRecup, 1)) = Application.Transpose(TabRecup)
.Columns.AutoFit = True
Erase TabRecup
End With
End If
Err.Clear
Next Ligne
On Error GoTo 0
End With
Application.ScreenUpdating = False

Rows("1:4").Select
Selection.Insert Shift:=xlDown
Rows("5:5").RowHeight = 25

Range("A1").Select
ActiveCell.FormulaR1C1 = "CONTROLE BUDGETAIRE"
Selection.Font.Bold = True
Range("A2").Select
Cells(2, 1) = Sheets(1).Name
Selection.Font.Bold = True
Range("A3").Select
ActiveCell.FormulaR1C1 = "Par JuB"
Selection.Font.Bold = True
Range("K2").Select
ActiveCell.FormulaR1C1 = "MAJ le"
Selection.Font.Bold = True
Range("L2").Select
ActiveCell.FormulaR1C1 = "=AUJOURDHUI()"
Selection.Font.Bold = True
Range("C1").Select
Selection.NumberFormat = "d-mmm-yy"
Range("A1:O3").Select
Selection.Interior.ColorIndex = 46
Selection.Font.ColorIndex = 2
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

Range("A5:O5").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Font.Bold = True
Selection.Interior.ColorIndex = 46
Selection.Font.ColorIndex = 2
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Range("A6:O6").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

End Sub

 

[Julbarbo]

Re : Boucle Macro Excel

Voici la PJ pour vous aider à y voire plus clair sur ma demande.

A l'exécution de la macro, seul le 1° onglet subit les modifications de mise en forme et je voudrais savoir comment l'imputer sur tous les onglets.

Merci d'avance.

P.S.:J'ai raccourci fortement le code

 

[Julbarbo]

Re : Boucle Macro Excel

Toujours personne, tant pis.
Est ce qu'il existe une autre solution pour créer les onglets à partir d'une base de données et mettre en forme.

 

[JONEY76]

Re : Boucle Macro Excel

J'ai une éventuelle solution

 

[JONEY76]

Re : Boucle Macro Excel

Ca y est !! voilà la bonne solution


Prends le fichier en dessous

 

[JONEY76]

Re : Boucle Macro Excel

voilà le bon fichier