'CodeName de la feuille contenant la liste complète : Sh_ListeComplète
'Tableau structuré de la liste complète : "ListeLivres"
Sub ListeThème()
Dim Tb(), Extraction(), Test(), ListeThèmes(), ListeTitres()
Dim DicThèmeSh As Object, DicDoublonsSht As Object, DicTrié As Object
Dim Titre, Thème, Filtre$, NomFeuille$
Dim Sz As Long, Lb As Long, Ub As Long, i As Long
Set DicThèmeSh = CreateObject("Scripting.dictionary")
Set DicDoublonsSht = CreateObject("Scripting.dictionary")
Set DicTrié = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With WorksheetFunction
'Listes sans doublon
ListeThèmes = .Sort(.unique(Sh_ListeComplète.[ListeLivres[Thèmes]]))
ListeTitres = .unique(Sh_ListeComplète.[ListeLivres[Titre]])
'Pour chaque doublon dans les titres, liste des thèmes correspondant
For Each Titre In ListeTitres
Filtre = "=ListeLivres[Titre]=""" & Replace(Titre, """", """""") & """"
Test = Evaluate(Filtre)
Extraction = .Filter(Sh_ListeComplète.[ListeLivres[Thèmes]], Test, "-")
If UBound(Extraction) > 1 Then
For Each Thème In Extraction
If DicDoublonsSht.exists(Thème) Then
Tb = DicDoublonsSht(Thème)
Sz = UBound(Tb) + 1
Else
Sz = 1
End If
ReDim Preserve Tb(1 To Sz)
Tb(Sz) = Titre
DicDoublonsSht(Thème) = Tb
Next
End If
Next
End With
'Tri du dico dans l'ordre des thèmes
Tb = DicDoublonsSht.keys
Lb = LBound(Tb): Ub = UBound(Tb)
Call tri(Tb, Lb, Ub)
For i = Lb To Ub
DicTrié(Tb(i)) = DicDoublonsSht(Tb(i))
Next
'Remplacement caractères non autorisés /\?*[] dans le nom des feuilles
For i = 1 To UBound(ListeThèmes, 1)
DicThèmeSh(ListeThèmes(i, 1)) = Replace(Replace(Replace(Replace(Replace(Replace(ListeThèmes(i, 1), "/", "_"), "\", "_"), "?", "_"), "*", "_"), "[", "_"), "]", "_")
Next
'Suppression des anciennes feuilles des thèmes
Application.DisplayAlerts = False: On Error Resume Next
For Each NomFeuille In DicThèmeSh.items
ThisWorkbook.Worksheets(NomFeuille).Delete
Next
Application.DisplayAlerts = True: On Error GoTo 0
'Création des feuilles thèmes pour les livres en doublon (ou plus)
i = 0
For Each Thème In DicTrié
i = i + 1
ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)).Name = DicThèmeSh(Thème)
ActiveWindow.DisplayGridlines = False
With ActiveSheet
.Cells(1).Value = "Livre en doublons"
Tb = DicDoublonsSht(Thème)
nb = UBound(Tb)
Cells(2, 1).Resize(nb).Value = Application.Transpose(Tb)
With .ListObjects.Add(xlSrcRange, .Cells(1).Resize(nb + 1), , xlYes)
.TableStyle = "TableStyleLight14"
.Name = "tb_Thème_" & Format(i, "000")
End With
.Columns(1).EntireColumn.AutoFit
End With
Next
Application.Goto Sh_ListeComplète.[ListeLivres]
Application.ScreenUpdating = False
Dim wsh As Worksheet
wsh.d
End Sub
Sub tri(a(), gauc, droi) ' Quick sort J. Boisgontier
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref: g = g + 1: Loop
Do While ref < a(d): d = d - 1: Loop
If g <= d Then
temp = a(g): a(g) = a(d): a(d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
