Extract Unique Values

Sub ExtractUniqueValues()
    Dim ws As Worksheet
    Dim wsTarget As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim dict As Object
    Dim outputRow As Long

    ' Vérifie si la feuille "stuff" existe, sinon, la crée
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Sheets("stuff")
    If wsTarget Is Nothing Then
        Set wsTarget = ThisWorkbook.Sheets.Add
        wsTarget.Name = "stuff"
    End If
    On Error GoTo 0

    ' Efface les données existantes dans la colonne A de la feuille "stuff"
    wsTarget.Columns("A").ClearContents

    ' Crée un dictionnaire pour stocker les valeurs uniques
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare

    ' Parcourt toutes les feuilles du fichier
    For Each ws In ThisWorkbook.Sheets
        ' Ignore la feuille "stuff" pour éviter les boucles infinies
        If ws.Name <> "stuff" Then
            ' Parcourt toutes les cellules utilisées de chaque feuille
            On Error Resume Next
            Set rng = ws.UsedRange
            On Error GoTo 0
            If Not rng Is Nothing Then
                For Each cell In rng
                    If Not IsEmpty(cell.Value) Then
                        If Not dict.exists(cell.Value) Then
                            dict.Add cell.Value, True
                        End If
                    End If
                Next cell
            End If
        End If
    Next ws

    ' Insère les valeurs uniques dans la colonne A de la feuille "stuff"
    outputRow = 1
    For Each Key In dict.Keys
        wsTarget.Cells(outputRow, 1).Value = Key
        outputRow = outputRow + 1
    Next Key

    ' Message de confirmation
    MsgBox "Extraction terminée ! " & dict.Count & " valeurs uniques trouvées.", vbInformation
End Sub