Option Explicit
Sub TEST()
Dim i As Long, j As Long, k As Long, l As Long
Application.ScreenUpdating = False
For i = 2 To 6 ' colonnes de 2 à 6 (B à F)
For k = 5 To 7 ' lignes de 5 à 7
If Cells(k, i).Interior.ColorIndex <> xlNone Then
For j = 2 To 6 ' colonnes de 2 à 6
If Cells(k, i) = Cells(11, j) And Cells(11, j).Interior.ColorIndex = xlNone Then ' cellule ligne 11 colonne j (2 à 6)
Cells(11, j).Interior.ColorIndex = 1 ' cellule ligne 11 colonne j (2 à 6)
Cells(11, j).Font.ColorIndex = 2 ' cellule ligne 11 colonne j (2 à 6)
End If
If Cells(k, i) = Cells(12, j) And Cells(12, j).Interior.ColorIndex = xlNone Then ' cellule ligne 12 colonne j (2 à 6)
Cells(12, j).Interior.ColorIndex = 1 ' cellule ligne 12 colonne j (2 à 6)
Cells(12, j).Font.ColorIndex = 2 ' cellule ligne 12 colonne j (2 à 6)
End If
If Cells(k, i) = Cells(13, j) And Cells(13, j).Interior.ColorIndex = xlNone Then ' cellule ligne 13 colonne j (2 à 6)
Cells(13, j).Interior.ColorIndex = 1 ' cellule ligne 13 colonne j (2 à 6)
Cells(13, j).Font.ColorIndex = 2 ' cellule ligne 13 colonne j (2 à 6)
End If
If Cells(k, i) = Cells(16, j) And Cells(16, j).Interior.ColorIndex = xlNone Then ' cellule ligne 16 colonne j (2 à 6)
Cells(16, j).Interior.ColorIndex = 1 ' cellule ligne 16 colonne j (2 à 6)
Cells(16, j).Font.ColorIndex = 2 ' cellule ligne 16 colonne j (2 à 6)
End If
If Cells(k, i) = Cells(17, j) And Cells(17, j).Interior.ColorIndex = xlNone Then ' cellule ligne 17 colonne j (2 à 6)
Cells(17, j).Interior.ColorIndex = 1 ' cellule ligne 17 colonne j (2 à 6)
Cells(17, j).Font.ColorIndex = 2 ' cellule ligne 17 colonne j (2 à 6)
End If
If Cells(k, i) = Cells(18, j) And Cells(18, j).Interior.ColorIndex = xlNone Then ' cellule ligne 18 colonne j (2 à 6)
Cells(18, j).Interior.ColorIndex = 1 ' cellule ligne 18 colonne j (2 à 6)
Cells(18, j).Font.ColorIndex = 2 ' cellule ligne 18 colonne j (2 à 6)
End If
Next j
End If
Next k
For l = 11 To 13 ' lignes de 11 à 13
If Cells(l, i).Interior.ColorIndex <> xlNone Then
For j = 2 To 6 ' colonnes de 2 à 6 (B à F)
If Cells(l, i) = Cells(11, j) And Cells(11, j).Interior.ColorIndex = xlNone Then ' cellule ligne 11 colonne j (2 à 6)
Cells(11, j).Interior.ColorIndex = 1 ' cellule ligne 11 colonne j (2 à 6)
Cells(11, j).Font.ColorIndex = 2 ' cellule ligne 11 colonne j (2 à 6)
End If
If Cells(l, i) = Cells(12, j) And Cells(12, j).Interior.ColorIndex = xlNone Then ' cellule ligne 12 colonne j (2 à 6)
Cells(12, j).Interior.ColorIndex = 1 ' cellule ligne 12 colonne j (2 à 6)
Cells(12, j).Font.ColorIndex = 2 ' cellule ligne 12 colonne j (2 à 6)
End If
If Cells(l, i) = Cells(13, j) And Cells(13, j).Interior.ColorIndex = xlNone Then ' cellule ligne 13 colonne j (2 à 6)
Cells(13, j).Interior.ColorIndex = 1 ' cellule ligne 13 colonne j (2 à 6)
Cells(13, j).Font.ColorIndex = 2 ' cellule ligne 13 colonne j (2 à 6)
End If
If Cells(l, i) = Cells(16, j) And Cells(16, j).Interior.ColorIndex = xlNone Then ' cellule ligne 16 colonne j (2 à 6)
Cells(16, j).Interior.ColorIndex = 1 ' cellule ligne 16 colonne j (2 à 6)
Cells(16, j).Font.ColorIndex = 2 ' cellule ligne 16 colonne j (2 à 6)
End If
If Cells(l, i) = Cells(17, j) And Cells(17, j).Interior.ColorIndex = xlNone Then ' cellule ligne 17 colonne j (2 à 6)
Cells(17, j).Interior.ColorIndex = 1 ' cellule ligne 17 colonne j (2 à 6)
Cells(17, j).Font.ColorIndex = 2 ' cellule ligne 17 colonne j (2 à 6)
End If
If Cells(l, i) = Cells(18, j) And Cells(18, j).Interior.ColorIndex = xlNone Then ' cellule ligne 18 colonne j (2 à 6)
Cells(18, j).Interior.ColorIndex = 1 ' cellule ligne 18 colonne j (2 à 6)
Cells(18, j).Font.ColorIndex = 2 ' cellule ligne 18 colonne j (2 à 6)
End If
Next j
End If
Next l
Next i
Application.ScreenUpdating = True
End Sub
Sub effacer()
Dim vReponse As String
vReponse = MsgBox("Voulez-vous effacer ?", vbYesNo + vbQuestion)
If vReponse = vbYes Then
Sheets("Feuil1").Range("B5:F18").Interior.ColorIndex = xlNone ' feuille 1 et cellules ( tableau B5-F18)
Sheets("Feuil1").Range("B5:F18").Font.ColorIndex = 1 ' feuille 1 et cellules ( tableau B5-F18)
Else
Exit Sub
End If
End Sub