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
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