Sub ListerDoublonsAvecLiensEtColorationFeuil1()
Dim wsData As Worksheet, wsReport As Worksheet
Dim dict As Object
Dim colArr As Variant, c As Variant
Dim lastRow As Long, ligne As Long
Dim rowData As String
Dim key As Variant
Dim splittedRows As Variant
Dim rowIndex As Long, groupIndex As Long
Dim colorsArr As Variant, colorValue As Long
Dim i As Long, j As Long, colIndex As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Randomize
' Définir la feuille contenant les données
Set wsData = ThisWorkbook.Worksheets("Feuil1") ' Adaptez le nom si besoin
' Colonnes à prendre en compte pour la clé de regroupement
colArr = Array("G", "I", "P", "Q", "R")
' Déterminer la dernière ligne utilisée parmi ces colonnes
lastRow = 0
For Each c In colArr
lastRow = Application.WorksheetFunction.Max(lastRow, wsData.Cells(wsData.Rows.Count, c).End(xlUp).Row)
Next c
If lastRow < 2 Then
MsgBox "Aucune donnée trouvée.", vbInformation
GoTo Fin
End If
' Créer un dictionnaire pour regrouper les lignes par clé
Set dict = CreateObject("Scripting.Dictionary")
For ligne = 2 To lastRow
rowData = ""
For Each c In colArr
rowData = rowData & "|" & CStr(wsData.Cells(ligne, c).Value)
Next c
' Si toutes les colonnes sont vides, ignorer
If rowData = "|||||" Then GoTo SuiteLigne
If dict.Exists(rowData) Then
dict(rowData) = dict(rowData) & "," & ligne
Else
dict.Add rowData, CStr(ligne)
End If
SuiteLigne:
Next ligne
' Supprimer la feuille "Rapport" si elle existe déjà
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Rapport").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Créer la nouvelle feuille de rapport
Set wsReport = ThisWorkbook.Worksheets.Add
wsReport.Name = "Rapport"
' En-têtes du rapport
wsReport.Range("A1").Value = "Clé de regroupement"
wsReport.Range("B1").Value = "Nb d'occurrences"
wsReport.Range("C1").Value = "Lignes (hyperliens)"
rowIndex = 2
groupIndex = 1
' Palette de couleurs claires (modifiez ou complétez la palette si besoin)
colorsArr = Array(RGB(144, 238, 144), RGB(173, 216, 230), RGB(255, 255, 224), RGB(255, 228, 181), RGB(221, 160, 221))
' Parcourir les groupes de doublons dans le dictionnaire
For Each key In dict.Keys
splittedRows = Split(dict(key), ",")
If UBound(splittedRows) > 0 Then ' groupe de doublons (au moins 2 occurrences)
' Choisir une couleur pour ce groupe
colorValue = colorsArr((groupIndex - 1) Mod (UBound(colorsArr) + 1))
' Remplir le rapport : clé et nombre d'occurrences
wsReport.Cells(rowIndex, 1).Value = Mid(key, 2) ' Supprime le premier "|"
wsReport.Cells(rowIndex, 2).Value = UBound(splittedRows) + 1
' Insérer en colonnes distinctes les hyperliens vers chaque ligne concernée (à partir de la colonne C)
colIndex = 3
For i = LBound(splittedRows) To UBound(splittedRows)
wsReport.Hyperlinks.Add Anchor:=wsReport.Cells(rowIndex, colIndex), _
Address:="", _
SubAddress:="'" & wsData.Name & "'!G" & splittedRows(i), _
TextToDisplay:=splittedRows(i)
colIndex = colIndex + 1
Next i
' Appliquer la couleur sur la ligne du rapport (colonnes A jusqu'à la dernière colonne utilisée pour les liens)
wsReport.Range(wsReport.Cells(rowIndex, 1), wsReport.Cells(rowIndex, colIndex - 1)).Interior.Color = colorValue
' **Coloration dans la feuille d'origine (Feuil1)**
' Pour chaque ligne du groupe, colorier les cellules des colonnes indiquées dans colArr
For i = LBound(splittedRows) To UBound(splittedRows)
For j = LBound(colArr) To UBound(colArr)
wsData.Range(colArr(j) & splittedRows(i)).Interior.Color = colorValue
Next j
Next i
rowIndex = rowIndex + 1
groupIndex = groupIndex + 1
End If
Next key
If rowIndex = 2 Then
MsgBox "Aucun doublon trouvé.", vbInformation
Else
MsgBox "Rapport créé dans la feuille 'Rapport' et coloration appliquée dans 'Feuil1'.", vbInformation
End If
Fin:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub