Sub Macro1()
'
' Macro1 Macro
'
'
Application.ScreenUpdating = False
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 1.29
Columns("B:B").ColumnWidth = 5.2
Range("B1:C4").Select
Selection.ClearContents
ActiveWindow.DisplayGridlines = False
Columns("B:B").Select
Selection.Font.Bold = True
'inserer deux lignes apres chaque total
For Each cell In Range("C5:C65536")
If cell.Value = "TOTAL" Then
cell.Offset(1, 0).Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
End If
Next cell
'inserer du texte dans les 2 lignes
For Each cell In Range("C5:C65536")
If cell.Value = "TOTAL" Then
cell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "%"
cell.Offset(2, 0).Select
ActiveCell.FormulaR1C1 = "evol"
End If
Next cell
'colorier les cellules media et evol YTD
For Each cell In Range("C5:C65536")
If cell.Value = "%" Then
cell.Interior.ColorIndex = 43
End If
Next cell
For Each cell In Range("C5:C65536")
If cell.Value = "evol" Then
cell.Interior.ColorIndex = 44
End If
Next cell
'iserer une colonne D et la mettre en blanc
Columns("D:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 3.14
Columns("D:D").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'enlever les colonnes autres et total
'separer les deux périodes
Range("F1").Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Offset(, -1) = ActiveCell Then
ActiveCell.Offset(, 1).Select
Else
ActiveCell.Columns.EntireColumn.Insert
ActiveCell.Offset(, 2).Select
End If
Loop
'Mettre le colonne total en gras
For Each cell In Range("E2:AAA2")
If cell.Value = "TOTAL" Then
cell.Select
Selection.EntireColumn.Select
Selection.Font.Bold = True
End If
Next cell
'inserer une colonne apres total
For Each cell In Range("E2:AAA2")
If cell.Value = "TOTAL" Then
cell.Offset(0, 1).Select
ActiveCell.Columns.EntireColumn.Insert
Selection.ColumnWidth = 10.29
End If
Next cell
'mettre sos pluri apres total
For Each cell In Range("E2:AAA2")
If cell.Value = "TOTAL" Then
cell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "% autre"
End If
Next cell
'compter le nombre de cellules pour P1
ma_valeur = Range("E1").Value
numblanks = 1
For Each c In Range("E1:AAA1")
If c.Value = ma_valeur Then
numblanks = numblanks + 1
End If
Next c
'compter le nombre de cellules pour P2
Range("AAA1").End(xlToLeft).Select
ma_valeur1 = ActiveCell.Value
numblanks1 = 1
For Each c1 In Range("E1:AAA1")
If c1.Value = ma_valeur1 Then
numblanks1 = numblanks1 + 1
End If
Next c1
'color la P1
For Each cell In Range("C5:C65536")
If cell.Value = "%" Then
cell.Offset(0, 2).Select
ActiveCell.Resize(, numblanks).Interior.ColorIndex = 43
End If
Next
'color la P2
For Each cell In Range("C5:C65536")
If cell.Value = "%" Then
cell.Offset(0, 3 + numblanks).Select
ActiveCell.Resize(, numblanks1).Interior.ColorIndex = 43
End If
Next
'color la P2
For Each cell In Range("C5:C65536")
If cell.Value = "evol" Then
cell.Offset(0, 3 + numblanks).Select
ActiveCell.Resize(, numblanks1).Interior.ColorIndex = 44
End If
Next
'calculer les % de la P1
For i = 5 To 300
If Range("C" & i).Value = "TOTAL" And Range("C" & i).Offset(0, numblanks) <> "" Then
Range("C" & i).Offset(0, numblanks).Select
montotal = ActiveCell.Value
End If
If Range("C" & i).Value = "TOTAL" And Range("C" & i).Offset(0, numblanks) <> "" Then
Range("C" & i).Offset(0, 2).Select
ActiveCell.Resize(, numblanks).Select
End If
For Each cell In Selection
If cell.Value <> "" Then
monsoutotal = cell.Value
cell.Offset(1, 0).Value = monsoutotal / montotal
End If
Next
Next i
'calculer les % de la P2
For i = 5 To 300
If Range("C" & i).Value = "TOTAL" And Range("C" & i).Offset(0, numblanks + numblanks1 + 1) <> "" Then
Range("C" & i).Offset(0, numblanks + numblanks1 + 1).Select
mondeuxiemetotal = ActiveCell.Value
Else:
GoTo ici
End If
If Range("C" & i).Value = "TOTAL" And Range("C" & i).Offset(0, numblanks + numblanks1 + 1) <> "" Then
Range("C" & i).Offset(0, 3 + numblanks).Select
ActiveCell.Resize(, numblanks1).Select
End If
For Each cell In Selection
If cell.Value <> "" Then
mondeuxiemesoutotal = cell.Value
cell.Offset(1, 0).Value = mondeuxiemesoutotal / mondeuxiemetotal
End If
Next
ici:
Next i
For Each cell In Range("C5:C65536")
If cell.Value = "%" Then
cell.Select
Selection.EntireRow.Select
Selection.Style = "Percent"
End If
Next
Application.ScreenUpdating = True
End Sub