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
| Sub Synthese_des_Couleurs()
Dim DerLig As Long, i As Long, j As Long, Deb As Long, Bas As Long, Lig As Long
Dim d1 As Object, d2 As Object
Dim Couleur As Long, NbCoul As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DerLig = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & DerLig).Clear
'Recherche N° de couleur
On Error Resume Next
ActiveWorkbook.Names("Coul").Delete
ActiveWorkbook.Names.Add Name:="Coul", RefersToR1C1:="=GET.CELL(63,Feuil1!RC2)"
Range("D2:D" & DerLig).FormulaR1C1 = "=Coul"
'RTelevé des noms et des couleurs
Range("D2:D" & DerLig).Value = Range("D2:D" & DerLig).Value
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each c In Range("A2:A" & DerLig)
If c.Text <> "" Then d1(c.Text) = ""
If Not d1.exists(c.Text) Then d1(c.Text) = ""
Next c
If d1.Count > 0 Then
[J1].Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
End If
For Each c In Range("D2:D" & DerLig)
If c.Text <> "" Then d2(c.Text) = ""
If Not d2.exists(c.Text) Then d2(c.Text) = ""
Next c
If d2.Count > 0 Then
[L1].Resize(1, d2.Count) = d2.keys
End If
'comptage des couleurs attribuées par nom
Range(Cells(2, "L"), Cells(d1.Count + 1, d2.Count + 11)).FormulaR1C1 = "=COUNTIFS(C1,RC10,C4,R1C)"
Range(Cells(2, "K"), Cells(d1.Count + 1, "K")) = "=COUNTIF(RC[1]:RC" & 11 + d2.Count & ","">""&0)"
Range(Cells(2, "K"), Cells(d1.Count + 1, d2.Count + 11)).Value = Range(Cells(2, "K"), Cells(d1.Count + 1, d2.Count + 11)).Value
For i = 2 To d1.Count + 2
Couleur = 0
NbCoul = 0
If Cells(i, "K") > 1 Then 'Recherche des noms aux multiples couleurs
For j = 12 To d2.Count + 11
If Cells(i, j) > 0 Then
Couleur = Couleur + Cells(1, j) 'Somme des couleurs pour un même nom
NbCoul = NbCoul + 1
End If
Next j
Cells(i, "K") = Int(Couleur / NbCoul) 'moyenne des couleurs trouvées
Else
Cells(i, "K") = "x"
End If
Next i
'Application des couleurs
Range("D2:D" & DerLig).FormulaR1C1 = "=VLOOKUP(RC1,C10:C11,2,0)"
For i = 2 To DerLig
If Cells(i, "D") = "x" Then
Cells(i, "C").Interior.Color = Cells(i, "B").Interior.Color
Else
Cells(i, "C").Interior.ColorIndex = Cells(i, "D")
End If
Next i
'Encadrements
Deb = 2
Bas = 2
For Deb = 2 To DerLig
Lig = Deb
Do While Cells(Lig, "A") = Cells(Lig + 1, "A") And Cells(Lig, "D") = Cells(Lig + 1, "D")
Lig = Lig + 1
Bas = Bas + 1
Loop
With Range(Cells(Deb, "C"), Cells(Bas, "C"))
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
Deb = Bas
Bas = Deb + 1
Next Deb
Columns("D:Z").ClearContents
End Sub |
Partager