Private Sub Worksheet_Activate()
Dim d1 As Object, d2 As Object, P As Range, ncol%, tablo, ub&, j%, i&, x$, resu(), lig&, xlig&, n%, decal%
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = vbTextCompare 'la casse est ignorée
Set d2 = CreateObject("Scripting.Dictionary")
d2.CompareMode = vbTextCompare
Set P = Sheets("Sheet1").[A1].CurrentRegion
ncol = P.Columns.Count
If ncol = 1 Then ncol = 2 ': Set P = P.Resize(, 2)
P.Columns(ncol).Name = "P" 'plage nommée
ThisWorkbook.Names.Add "N", ncol 'nom défini
P.Columns(ncol).Replace "", "<vide>" 'renseigne les cellules vides
ReDim resu(1 To [MAX(1,2*SUM(N(MATCH(P,P,0)=ROW(P)))-2)], 1 To [1+(N-1)*MAX(COUNTIF(P,P))])
tablo = P.Resize(, ncol) 'matrice, plus rapide, au moins 2 éléments
P.Columns(ncol).Replace "<vide>", "" 'rétablit les cellules vides
'---remplacement de chaque doublon par un espace dans chaque colonne sauf la dernière (facultatif car l'idée est discutable)---
ub = UBound(tablo)
For j = 1 To ncol - 1
For i = 2 To ub
x = tablo(i, ncol) & tablo(i, j)
If d1.exists(x) Then tablo(i, j) = " " Else d1(x) = ""
Next i
d1.RemoveAll 'RAZ
Next j
'---remplissage du tableau resu---
resu(1, 1) = tablo(1, ncol)
lig = 1
For i = 2 To ub
x = tablo(i, ncol)
If Not d1.exists(x) Then
d1(x) = lig 'mémorise la ligne
resu(lig + 1, 1) = x
lig = lig + 2
End If
xlig = d1(x) 'récupère la ligne
d2(x) = d2(x) + 1 'comptage
n = d2(x)
decal = (ncol - 1) * (n - 1)
For j = 1 To ncol - 1
resu(xlig, 1 + j + decal) = tablo(1, j) & n
resu(xlig + 1, 1 + j + decal) = tablo(i, j)
Next j, i
'---restitution + MFC---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
With [A3] '1ère cellule de restitution, à adapter
.Formula = "=MOD(ROW()-ROW(" & .Address & "),2)=0"
x = .FormulaLocal 'pour fonctionner sur toute version
With .Resize(UBound(resu), UBound(resu, 2))
.Value = resu
.FormatConditions.Add xlExpression, Formula1:=x 'MFC
.FormatConditions(1).Font.Bold = True 'police en gras
End With
End With
With UsedRange
.Columns(1).AutoFit 'ajuste la largeur
For i = 13 To .Columns.Count Step ncol - 1: .Columns(i).AutoFit: Next 'largeurs pour les adresses
End With
End Sub
Les caractères en gras sont dus à une MFC, il suffit de ne pas la créer, vous n'aviez pas compris ?Est-il possible de faire en sorte que tout est en caractère normal, SVP ?
Private Sub Worksheet_Activate()
Dim d1 As Object, d2 As Object, P As Range, ncol%, tablo, ub&, j%, i&, x$, resu(), lig&, xlig&, n%, decal%
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = vbTextCompare 'la casse est ignorée
Set d2 = CreateObject("Scripting.Dictionary")
d2.CompareMode = vbTextCompare
Set P = Sheets("Sheet1").[A1].CurrentRegion
ncol = P.Columns.Count
If ncol = 1 Then ncol = 2
P.Columns(ncol).Replace "", "<vide>" 'renseigne les cellules vides
tablo = P.Resize(, ncol) 'matrice, plus rapide, au moins 2 éléments
P.Columns(ncol).Replace "<vide>", "" 'rétablit les cellules vides
'---remplacement de chaque doublon par un espace dans chaque colonne sauf la dernière (facultatif car l'idée est discutable)---
ub = UBound(tablo)
For j = 1 To ncol - 1
For i = 2 To ub
x = tablo(i, ncol) & tablo(i, j)
If d1.exists(x) Then tablo(i, j) = " " Else d1(x) = ""
Next i
d1.RemoveAll 'RAZ
Next j
'---dimensionnement du tableau resu---
For i = 2 To ub
x = tablo(i, ncol)
d1(x) = d1(x) + 1 'comptage
Next i
If d1.Count = 0 Then d1(0) = 0
ReDim resu(1 To IIf(d1.Count, 2 * d1.Count, 1), 1 To 1 + (ncol - 1) * Application.Max(d1.items))
d1.RemoveAll 'RAZ
'---remplissage du tableau resu---
resu(1, 1) = tablo(1, ncol)
lig = 1
For i = 2 To ub
x = tablo(i, ncol)
If Not d1.exists(x) Then
d1(x) = lig 'mémorise la ligne
resu(lig + 1, 1) = x
lig = lig + 2
End If
xlig = d1(x) 'récupère la ligne
d2(x) = d2(x) + 1 'comptage
n = d2(x)
decal = (ncol - 1) * (n - 1)
For j = 1 To ncol - 1
resu(xlig, 1 + j + decal) = tablo(1, j) & n
resu(xlig + 1, 1 + j + decal) = tablo(i, j)
Next j, i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
[A3].Resize(UBound(resu), UBound(resu, 2)) = resu 'A3 : 1ère cellule de restitution, à adapter
With UsedRange
.Columns(1).AutoFit 'ajuste la largeur
For i = 13 To .Columns.Count Step ncol - 1: .Columns(i).AutoFit: Next 'largeurs pour les adresses
End With
End Sub