Sub MEF() Dim Cell As Range 'cellule
Dim Ws As Worksheet 'feuille de style
Dim Zone As Range 'zone de celule
Dim tableau() As Integer 'tableau pour le parcours des totaux
Dim indice As Integer 'indice pr le tableau rpecedent
Dim plageATraiter As String
Dim formatCellule As String
Dim alignementCellule As String
Dim EtatStatusBar As Boolean
Dim Ligne As String
' Empècher le calcul, le rafraichissement, les évènements
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
'état de la barre d'état
EtatStatusBar = Application.DisplayStatusBar
'affichage de la barre d'état
Application.DisplayStatusBar = True
'affichage du message
'on selectionne la feuille active
Set Ws = Application.ActiveWorkbook.ActiveSheet
Ligne = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
plageATraiter = "A16:Z" & Ligne
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.StatusBar = "Suppression des lignes Total ..."
'on comence par retirer toutes les lignes total
ReDim tableau(1)
indice = 1
For Each Cell In Ws.Range(plageATraiter)
If InStr(Cell, "Total") > 0 Then
tableau(indice) = Cell.Row
indice = indice + 1
' redimension du tableau
ReDim Preserve tableau(indice)
End If
Next Cell
For colonneTableau = indice - 1 To 1 Step -1
' Set colonne = tableau(colonneTableau)
Rows(tableau(colonneTableau)).Delete
Next colonneTableau
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.StatusBar = "Mise en page des Cellules ..."
'on fait la mise en page : defusion des celules puis fusion par ligne
For Each Cell In Ws.Range(plageATraiter)
'on defusionne la cellule
If Cell.MergeCells Then
Dim ZoneFusion As Range
Set ZoneFusion = Cell.MergeArea
Dim Valeur As String
Valeur = Cell.Value
alignementCellule = Cell.HorizontalAlignment
formatCellule = Cell.NumberFormat
Cell.UnMerge
'on fusionne les lignes de cette mergearea
Dim NumLigne As Integer
With ZoneFusion
'adapte la taille du texte des cellules fusionnées
ZoneFusion.Font.Size = 10
'For NumLigne = 1 To .Rows.Count
' .Rows(NumLigne).Merge
'Next NumLigne
'on recopie les valeurs dans ces lignes
'For NumLigne = 2 To .Rows.Count
.NumberFormat = "@" 'formatage texte
.HorizontalAlignment = xlGeneral
.Value = Valeur
'Next NumLigne
'adapte la taille du texte des cellules fusionnées
ZoneFusion.Font.Size = 10
'retrait du retour a la ligne
.WrapText = False
End With
'adapte la taille du texte des cellules non fusionnées
Else
If Cell.Value <> "" Then
Cell.Font.Size = 10
End If
End If
Next Cell
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.StatusBar = "Traitement de la page de données " & plageATraiter & " terminé"
'réinitialisation de la barre
Application.StatusBar = False
'remise à l'état d'origine
Application.DisplayStatusBar = EtatStatusBar
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Application.StatusBar = "Défusion des cellules..."
'défusionner les celulles
With Cells
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.StatusBar = "Suppression des colonnes vides..."
With Range("C:G,J:J,L:L,N:P,R:Z")
'supprimer les colonnes vides
.Delete Shift:=xlToLeft
End With
With Rows("1:12")
'supprimer les lignes vides du haut de la page
.Delete Shift:=xlUp
End With
With Columns("A:Z")
'taille des colonnes =10
.ColumnWidth = 10
End With
Ligne = ActiveSheet.UsedRange.Rows.Count - 1
'Rows("1:" & Ligne).Select
'Range(Selection, Selection.End(xlDown)).Select
With Range(Rows("1:" & Ligne), Rows("1:" & Ligne).End(xlDown))
.RowHeight = 12.75
'hauteur des lignes = 12.75
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''
With Range("H3")
.FormulaR1C1 = "'centre profit"
.Characters(Start:=1, Length:=13).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
' .TintAndShade = 0
' .ThemeFont = xlThemeFontNone
End With
With Range("I3")
.FormulaR1C1 = "resp travaux"
.Characters(Start:=1, Length:=12).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
' .TintAndShade = 0
' .ThemeFont = xlThemeFontNone
End With
With Range("J3")
.FormulaR1C1 = "resp centre"
.Characters(Start:=1, Length:=11).Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
' .TintAndShade = 0
' .ThemeFont = xlThemeFontNone
End With
'écrire les titres pour les calculs
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.StatusBar = "Calculs en cours..."
Range("H4").FormulaR1C1 = "=+LEFT(RC[-6],11)"
Range("H4").AutoFill Destination:=Range("H4:H" & Ligne)
'Range("H4:H" & Ligne).Select
'=gauche
Range("I4").FormulaR1C1 = "=+VLOOKUP(RC[-1],'table SAP'!C[-8]:C[-5],4,0)"
Range("I4").AutoFill Destination:=Range("I4:I" & Ligne)
'Range("I4:I" & Ligne).Select
'recherchev resp travaux
Range("J4").FormulaR1C1 = "=VLOOKUP(RC[-2],'table SAP'!C[-9]:C[-5],5,0)"
Range("J4").AutoFill Destination:=Range("J4:J" & Ligne)
'Range("J4:J" & Ligne).Select
'recherchev resp centre
' Activer le calcul, le rafraichissement, les évènements
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub