1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
| Sub Synthese()
Dim ShSyn As Worksheet
Dim Plage As Range
Dim ListeFeuille()
Dim i As Long, j As Long
Dim DerLig As Long, DerCol As Long, Decalage As Long
Application.ScreenUpdating = False
' la liste des feuilles qui ont un tableau
ListeFeuille = Array("Tableau1", "Tableau2")
With ThisWorkbook
'$$$ CREATION DE LA FEUILLE DE SYNTHESE $$$
On Error Resume Next: Set ShSyn = .Worksheets("Synthèse")
ShSyn.Cells.Delete: On Error GoTo 0
If ShSyn Is Nothing Then Set ShSyn = .Worksheets.Add: ShSyn.Name = "Synthèse"
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$ RECOPIE DES TABLEAU VERS LA FEUILLE DE SYNTHESE $$$
For i = LBound(ListeFeuille) To UBound(ListeFeuille)
With .Worksheets(ListeFeuille(i))
.Rows(1).Copy ShSyn.Rows(1)
With .UsedRange
.Resize(.Rows.Count + 1, .Columns.Count).Offset(1, 0).Copy _
ShSyn.Cells(ShSyn.Rows.Count, 1).End(xlUp)(2)
End With
End With
Next i
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
End With
With ShSyn
DerLig = .UsedRange.Rows.Count: DerCol = .UsedRange.Columns.Count
'$$$ RETRAIT DES FUSIONS DE CELLULES $$$
For i = DerLig To 2 Step -1
If .Cells(i, 1).MergeCells Then Call Demerge(ShSyn, i)
Next i
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$ SUPPRESSION DES LIGNES VIDES $$$
For i = DerLig To 2 Step -1
If .Cells(i, 1).Value = "" Or .Cells(i, 1).Interior.Color = vbRed Then .Rows(i).Delete: Decalage = Decalage + 1
Next i
DerLig = DerLig - Decalage
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$$$$$$$$$$$$$$ TRI $$$$$$$$$$$$$$$$$$
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Columns(9), SortOn:=xlSortOnValues, Order:=xlAscending, _
CustomOrder:="banque1,banque3,banque2", DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Columns(8), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange ShSyn.UsedRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$$$ REMISE EN PLACE DES FUSIONS $$$$$
For i = DerLig To 2 Step -1
With .Cells(i, 1)
If Not .MergeCells _
And .Value = .Offset(-1, 0).Value _
And .Offset(0, 6).Value = .Offset(-1, 6).Value _
And .Offset(0, 7).Value = .Offset(-1, 7).Value Then
Call Demerge(ShSyn, i, True)
End If
End With
Next i
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$$$$$$$$ LIGNE DES TOTAUX $$$$$$$$$$$
'$$$$$$$$$$ ET MISE EN FORME $$$$$$$$$$$
With .Cells(DerLig + 1, 4)
.Value = "TOTAUX"
.Resize(1, 4).Font.Bold = True
End With
.Cells(DerLig + 1, 1).Resize(, 9).Interior.Color = 12632256
With .Range(.Cells(DerLig + 1, 5), .Cells(DerLig + 1, 7))
.Formula = "=SUM(R[-" & DerLig - 1 & "]C:R[-1]C)"
'.Value = .Value
.Interior.Color = -1
End With
.UsedRange.Columns.AutoFit
With .Cells(1, 1).CurrentRegion
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
End Sub
Sub Demerge(Sh As Worksheet, Ligne As Long, Optional Contraire As Boolean = False)
With Sh
If Not Contraire Then
For t = 1 To .UsedRange.Columns.Count
With .Cells(Ligne, t)
If .MergeCells Then
valeur = .MergeArea.Cells(1, 1).Value
nblig = .MergeArea.Cells.Count
.UnMerge
For c = 0 To nblig - 1
Sh.Cells(Ligne - c, t).Value = valeur
Next c
End If
End With
Next t
Else
valeur = .Cells(Ligne, 1)
nblig = 1
While .Cells(Ligne - nblig - 1, 1) = .Cells(Ligne - nblig, 1) _
And .Cells(Ligne - nblig - 1, 7) = .Cells(Ligne - nblig, 7) _
And .Cells(Ligne - nblig - 1, 8) = .Cells(Ligne - nblig, 8) _
And .Cells(Ligne - nblig - 1, 9) = .Cells(Ligne - nblig, 9)
nblig = nblig + 1
Wend
Application.DisplayAlerts = False
.Range(.Cells(Ligne - nblig, 1), .Cells(Ligne, 1)).Merge
.Range(.Cells(Ligne - nblig, 7), .Cells(Ligne, 7)).Merge
.Range(.Cells(Ligne - nblig, 8), .Cells(Ligne, 8)).Merge
.Range(.Cells(Ligne - nblig, 9), .Cells(Ligne, 9)).Merge
Application.DisplayAlerts = True
End If
End With
End Sub |