Sub Detail_Minick_3()
Dim NbrLignes As Long, CptLignes As Long
Dim MarchesExclus As String
MarchesExclus = ";CP;CPC;PF;PFC;PFI;"
With Sheets("DETAIL")
Application.ScreenUpdating = False
'Effacement des anciennes valeurs
.Cells.Delete
'Copie des colonnes de la source
NbrLignes = Sheets("detail source").Range("C65526").End(xlUp).Row
Sheets("detail source").Range("A13:A" & NbrLignes & ",C13:K" & NbrLignes).Copy .Range("A1")
'Masquage de la colonne E
.Columns("E").Hidden = True
NbrLignes = .Range("A65526").End(xlUp).Row
'Mise en numerique des valeurs
[B][COLOR=Red].Range("K2:N" & NbrLignes).FormulaR1C1 = "=IF(RC[-4]=""-"",""-"",VALUE(RC[-4]))"[/COLOR][/B]
.Calculate
.Range("G2:J" & NbrLignes).Value = .Range("K2:N" & NbrLignes).Value
.Range("K2:N" & NbrLignes).ClearContents
'Suppression des Marches Exclus
For CptLignes = NbrLignes To 2 Step -1
If InStr(1, MarchesExclus, ";" & UCase(.Range("B" & CptLignes).Value) & ";") <> 0 Then
.Rows(CptLignes).Delete
NbrLignes = NbrLignes - 1
End If
Next
.Columns("A").ColumnWidth = 26
.Columns("C").ColumnWidth = 14
.Columns("D").ColumnWidth = 40
'Centrage et hauteur des cellules
With .Range("A1:J" & NbrLignes)
.RowHeight = 26
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Sort key1:=.Range("A1"), order1:=xlAscending, key2:=.Range("B1"), order2:=xlAscending, key3:=.Range("C1"), order3:=xlAscending, Header:=xlYes
End With
'Alignement a gauche de la colonne D
.Range("D1:D" & NbrLignes).HorizontalAlignment = xlLeft
.Range("D1").HorizontalAlignment = xlCenter
'Mise en forme de la colonne commentaire
.Range("A1:A" & NbrLignes).Copy
With .Range("K1:R" & NbrLignes)
.PasteSpecial Paste:=xlPasteFormats
.Borders(xlInsideVertical).LineStyle = xlNone
End With
.Range("K1:R1").HorizontalAlignment = xlCenterAcrossSelection
.Range("K1").Value = "Commentaires"
'SOUS TOTAUX
Application.DisplayAlerts = False
NbrLignes = .Range("A65526").End(xlUp).Row
.Range("A1:R" & NbrLignes).Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(7, 8, 10), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
NbrLignes = .Range("A65526").End(xlUp).Row
.Range("A1:R" & NbrLignes).Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(7, 8, 10), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
Application.DisplayAlerts = True
'MFC
With .UsedRange
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""Total"";$A1;1)))")
With .Font
.Bold = True
.Italic = False
End With
.Interior.ColorIndex = 35
End With
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""Total"";$B1;1)))")
.Interior.ColorIndex = 36
End With
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""CENTRE DTH"";$D1;1)))")
With .Font
.Bold = True
.Italic = False
End With
.Interior.ColorIndex = 33
End With
End With
NbrLignes = .Range("A65526").End(xlUp).Row
'Format cellules colonne Ecart%
With .Range("I2:I" & NbrLignes)
.NumberFormat = "[Red]0.00%;[Blue]-0.00%"
[B][COLOR=Red].FormulaR1C1 = "=IF(OR(RC[-1]=0,RC[-1]=""-""),""-"",RC[1]/RC[-1])"[/COLOR][/B]
End With
'Mise en forme du total general
With .Range("D" & NbrLignes)
.Value = "TOTAL CENTRE DTH"
.HorizontalAlignment = xlLeft
End With
.Range("A" & NbrLignes).Value = ""
'Mise en forme des bordures des lignes de total
For CptLignes = 2 To NbrLignes
If .Range("B" & CptLignes).Value = "Total" Then
.Rows(CptLignes).Delete
CptLignes = CptLignes - 1
ElseIf InStr(1, .Range("A" & CptLignes).Value, "Total") <> 0 _
Or InStr(1, .Range("B" & CptLignes).Value, "Total") <> 0 Then
.Range("A" & CptLignes & ":R" & CptLignes).Borders.LineStyle = xlContinuous
.Range("K" & CptLignes & ":R" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
ElseIf InStr(1, .Range("D" & CptLignes).Value, "TOTAL") <> 0 Then
.Range("A" & CptLignes & ":R" & CptLignes).Borders.LineStyle = xlContinuous
.Range("A" & CptLignes & ":F" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
.Range("K" & CptLignes & ":R" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
End If
Next CptLignes
'Ajout du titre et mise en forme
.Rows(1).Insert
.Range("A1").FormulaR1C1 = "=MID(CELL(""nomfichier""),FIND(""["",CELL(""nomfichier""))+1,FIND(""."",CELL(""nomfichier""))-FIND(""["",CELL(""nomfichier""))-1)"
.Range("F1").Value = "DETAIL"
.Range("A1:D1").HorizontalAlignment = xlCenterAcrossSelection
.Range("F1:J1").HorizontalAlignment = xlCenterAcrossSelection
With .Range("A1:D1,F1:J1")
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
With .Font
.Name = "Arial"
.Size = 24
End With
End With
'Mise en page
With .PageSetup
[B][COLOR=Red].PrintTitleRows = "$1:$1"[/COLOR][/B]
.LeftHeader = ""
.CenterHeader = "&F"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "Page &P"
.RightFooter = ""
.LeftMargin = Application.CentimetersToPoints(0.4)
.RightMargin = Application.CentimetersToPoints(0.4)
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(0.8)
.HeaderMargin = Application.CentimetersToPoints(0.4)
.FooterMargin = Application.CentimetersToPoints(0.4)
.Orientation = xlLandscape
.Zoom = 59
End With
Application.ScreenUpdating = True
End With
End Sub