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
| Sub Macro1()
Dim O As Object 'déclare la variable O (Onglet)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DC As Byte 'déclare la variable DC (Dernière Colonne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)
Dim TMPC As Variant 'déclare la variable TMPC (tableau TeMProraire de la Colonne)
Dim PLVC As Range 'déclare la variable PLVC (Plage Visible de la Colonne)
Dim K As Byte 'déclare la variable K (incrément)
Dim TN() As Byte 'déclare le tableau de variables indexées TN (Tableau des Nombres)
Dim L As Byte 'déclare la variable L (incrément)
Dim MAX As Byte 'déclare la varialbe MAX
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("Feuil1") 'définit l'onglet O
DL = O.Cells(Application.Rows.Count, 3).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 3 (=C) de l'onglet O
DC = O.Cells(1, Application.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne éditée DC de la ligne 1 de l'onglet O
Set PL = O.Range("C2:C" & DL) 'définit la plage PL (colonne 3 = C)
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In PL 'boucle sur toutes les cellules CEL de la plage PL
D(CEL.Value) = "" 'alimente le dictionnaire
Next CEL 'prochaine cellule de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP les valeurs uniques (sans doublon) du dictionnaire D
For I = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau TMP
O.Range("A1").AutoFilter Field:=3, Criteria1:=TMP(I) 'filtre la colonne 3 (=C) de l'onglet O avec l'élément TMP(I) comme critère
For J = 4 To DC 'boucle 2 : sur les colonnes 4 à DC
'définit la plage PLV (cellules visibles (non filtrée) de la colonne C décalée de J-3 colonnes à droite
Set PLV = PL.Offset(0, J - 3).SpecialCells(xlCellTypeVisible)
If PLV.Cells.Count = 1 Then GoTo suite 'si le nombre de cellules visibles est égal à un, va à l'étiquette "suite"
Set D = CreateObject("Scripting.Dictionary") 'redéfinit le dictionnaire D
For Each CEL In PLV 'boucle 3 :sur toutes les cellules CEL de la plage PLV
D(CEL.Value) = "" 'alimente le dictionnaire D
Next CEL 'prochaine cellule de la boucle 3
TMPC = D.keys 'récupère dans le tableau temporaire TMPC les valeurs uniques (sans doublon) du dictionnaire D
If UBound(TMPC) > 0 Then 'condition 1 : si le nombre d'élément du tableau TMPC est supérieur à 1 (Ubound(TMPC) = 0 => 1 élément)
For K = 0 To UBound(TMPC) 'boucle 4 : sur tous les éléments du tableau temporaire TMPC
ReDim Preserve TN(K) 'redimensionne le tableau TN
TN(K) = Application.WorksheetFunction.CountIf(PLV, TMPC(K)) 'définit la varaible indexée TN(K) (nombre d'occurrences de TMPC(K) dans la plage PLV)
Next K 'prochain élément de la boucle 4
For K = 0 To UBound(TN) 'boucle 5 : sur les éléments tu tableau TN
For L = 0 To UBound(TN) 'boucle 6 : sur les éléments tu tableau TN
If TN(L) > TN(K) Then MAX = L 'récupère dans la variable MAX l'élément qui a le plus grand nombre d'occurrences dans la plage PLV
Next L 'prochaine élément de la boucle 6
Next K 'prochaine élément de la boucle 5
'filtre la colonne J de l'onglet O avec les éléments différents ded TMPC(MAX) comme critère
O.Range("A1").AutoFilter Field:=J, Criteria1:="<>" & TMPC(MAX)
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
'définit la plage PLVC des cellules visibles (non filtrée) de la colonne C décalée de J-3 colonens à droite
Set PLVC = PL.Offset(0, J - 3).SpecialCells(xlCellTypeVisible)
'quand le critère est un numéro de téléphone avec son format spécial, la ligne ci-dessus génère une erreur
If Err <> 0 Then 'condition 2 : si une erreur a été générée
Err.Clear 'efface l'erreur
O.Range("A1").AutoFilter Field:=J 'supprime le filtre automatique avec l'élément TMPC(K)
'filtre la colonne J de l'onglet O avec les éléments différents ded TMPC(MAX) comme critère
O.Range("A1").AutoFilter Field:=J, Criteria1:="<>" & Format(TMPC(MAX), "0#"" ""##"" ""##"" ""##"" ""##")
'définit la plage PLVC des cellules visibles (non filtrée) de la colonne C décalée de J-3 colonens à droite
Set PLVC = PL.Offset(0, J - 3).SpecialCells(xlCellTypeVisible)
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
'si le nombre de cellules visibles est égal à un, colore la cellule de jaune
PLVC.Interior.ColorIndex = 6
O.Range("A1").AutoFilter Field:=J 'supprime le filtre automatique avec l'élément TMPC(K) comme critère
End If 'fin de la condition 1
Next J 'prochaine colonne de la boucle 2
suite: 'étiquette
O.Range("A1").AutoFilter 'supprime le filtre automatique
Next I 'prochaine élément de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub |
Partager