XL 2010 Dresser un Array recensant les différentes extensions des fichiers d’un dossier

Sub Extraire_Extensions()
    Dim Chemin_Dir$, Objet1 As Object, Objet2 As Object, Array_Extensions, Fich_Ext$
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Choisir"
        .AllowMultiSelect = False
        .Title = "Choisissez le dossier à examiner"
        .Show
        If .SelectedItems.Count > 0 Then
            Chemin_Dir = .SelectedItems(1)
        Else
            MsgBox "pas de dossier sélectionné" & vbLf & "Abandon de la notification", vbOKOnly + vbInformation, "Information"
            Exit Sub
        End If
    End With
    Set Objet1 = CreateObject("Scripting.FileSystemObject")
    Set Objet2 = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin_Dir)
    For Each Objet1 In Objet2.Files
        If InStrRev(Objet1.Name, ".") Then
            Fich_Ext = Mid(Objet1.Name, InStrRev(Objet1.Name, "."))
            If InStr(1, Array_Extensions, Fich_Ext) = 0 Then Array_Extensions = IIf(Array_Extensions = "", Fich_Ext, Array_Extensions & "|" & Fich_Ext)
        End If
    Next Objet1
    Array_Extensions = Split(Array_Extensions, "|")
    MsgBox "Liste des " & UBound(Array_Extensions) - LBound(Array_Extensions) + 1 & " extensions du dossier : " & Chemin_Dir & vbLf & Join(Array_Extensions, vbLf), vbOKOnly + vbInformation
End Sub

Public Function GetFileExtension(fichier As String) As String
'Renvoie l'extension d'un fichier
'- fichier : le nom ad integrum du fichier (ex : "La vie ténébreuse de Mère Térésa.pdf") --> .pdf

    GetFileExtension = Right(fichier, Len(fichier) - (InStrRev(fichier, ".") - 1))
End Function

Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from your array using the collection method.
'NOTES: (1) This function returns unique elements in your array, but it converts your array elements to strings.
'SOURCE: https://wellsr.com/vba/2017/excel/vba-remove-duplicates-from-array/#:~:text=The%20RemoveDupesColl%20removes%20duplicate%20entries,to%20an%20array%20of%20strings.
'-----------------------------------------------------------------------
    Dim i As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

    For i = LBound(MyArray) To UBound(MyArray) 'convert to string
        arrDummy1(i) = CStr(MyArray(i))
    Next
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(MyArray) To arrColl.Count + LBound(MyArray) - 1)
    i = LBound(MyArray)
    For Each item In arrColl
       arrDummy(i) = item
       i = i + 1
    Next
    RemoveDupesColl = arrDummy
End Function

Sub Tri(a, gauc, droi) 'Quick sort
'BOISGONTIER

    Dim ref, g, d, temp
    
    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

Sub ListeFichiers(Repertoire As String)
'Affiche la liste de tous les fichiers contenus dans "Repertoire" (Dossier unique ou Dossier + Sous-Dossiers)
'SilkyRoad (https://excel.developpez.com/faq/?page=FichiersDir#ListeFichiersScriptingRuntime)
'Magic_Doctor
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils / Références --> Cochez la ligne "Microsoft Scripting RunTime"
 
    Dim Fso As Scripting.FileSystemObject, SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder, FileItem As Scripting.File
    Dim i As Long, nbFichiers As Long, ext$, extAV%, TailleFichier, TotalTaillesFichiers, secondes#, TotalSecondes#
    Dim j As Byte, fichiersAV, fichiersSup, extOut$
    Dim ArrayExt(), k, ArrayExtSansDoublons()
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
    i = Hoja1.Range("A" & Rows.Count).End(xlUp).Row + FirstLigne  'récupèration du numéro de la dernière ligne vide dans la colonne A
    fichiersAV = Array(".avi", ".wav", ".mp3", ".mp4")            'formats reconnus par la fonction "GetVideoDuration"
    fichiersSup = Array(".ini", ".crdownload", ".m4a", ".pdgcp", ".m3u", ".avif", ".img", ".htm") 'formats indésirables
    
    On Error Resume Next
    
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        ext = GetFileExtension(FileItem.Name)  'extension du fichier
        
        For j = LBound(fichiersAV) To UBound(fichiersAV)   'on passe en revue tout l'array "fichiersAV"
            If ext = fichiersAV(j) Then extAV = extAV + 1  'décompte des fichiers Audio/Vidéo reconnus par la fonction "GetVideoDuration"
        Next
        For j = LBound(fichiersSup) To UBound(fichiersSup) 'on passe en revue tout l'array "fichiersSup"
            If ext = fichiersSup(j) Then extOut = fichiersSup(j)
        Next
        
        If Left(FileItem.Name, 2) = "~$" Or Left(FileItem.Name, 8) = "AlbumArt" Or FileItem.Name = "Folder.jpg" Or FileItem.Name = "Thumbs.db" Or ext = extOut Then GoTo fin 'élimination des fichiers indésirables

        k = k + 1
        ReDim Preserve ArrayExt(k)
        ArrayExt(k) = ext 'on dresse l'Array "ArrayExt" avec toutes les extensions des différents fichiers
        
        Cells(i, 1) = i - FirstLigne                                                                          'numéro d'ordre du fichier
        Cells(i, 2) = FileItem.Name                                                                           'nom du fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=FileItem.ParentFolder & "\" & FileItem.Name  'ajoute un lien hypertexte vers le fichier
        Cells(i, 3) = ext  'occulté dans la feuille (tri)

        TailleFichier = FileLen(FileItem)
        Cells(i, 4) = TailleFichier  'taille du fichier en bytes (occulté dans la feuille : tri)
        TotalTaillesFichiers = TotalTaillesFichiers + TailleFichier  'taille de l'ensemble des fichiers en bytes
        
        Cells(i, 5) = BytesEnTGMK(TailleFichier) 'conversion des bytes en Kb, Mb, Gb ou Tb pour la taille du fichier
        
        If Evaluate("Remember_VoirDuration") = True Then                          'récupération de la durée des fichiers Audio/Vidéo
            If ext = ".avi" Or ext = ".wav" Or ext = ".mp3" Or ext = ".mp4" Then  'formats reconnus par la fonction "GetVideoDuration"
                secondes = GetVideoDuration(Repertoire & "\" & FileItem.Name)
                TotalSecondes = TotalSecondes + secondes                          'nombre total de secondes de TOUS les fichiers
                Cells(i, 6) = Format(secondes / 86400, "hh:mm:ss")                'durée du fichier Audio/Vidéo
            End If
        End If
        
        i = i + 1 'nombre de fichiers
fin:
    Next
    
    ArrayExtSansDoublons = RemoveDupesColl(ArrayExt)          'élimination des doublons contenus dans l'Array "ArrayExt"
    Tri ArrayExtSansDoublons, 0, UBound(ArrayExtSansDoublons) 'tri l'Array "ArrayExtSansDoublons" par ordre alphabétique
    Sheets("Hoja1").ComboBoxExt.List = ArrayExtSansDoublons   'dresse la liste du Combobox "ComboBoxExt"
    
    ...
    
End Sub

Function BytesEnTGMK(taille) As String
'Converti des Bytes en Tb, Gb, Mb ou Kb
'Magic_Doctor

    If taille >= 10 ^ 12 Then
        BytesEnTGMK = NombreEnTxt(taille / 1024 ^ 4, 2, "") & " Tb"
    ElseIf taille >= 10 ^ 9 Then
        BytesEnTGMK = NombreEnTxt(taille / 1024 ^ 3, 2, "") & " Gb"
    ElseIf taille >= 10 ^ 6 Then
        BytesEnTGMK = NombreEnTxt(taille / 1024 ^ 2, 2, "") & " Mb"
    Else
        BytesEnTGMK = NombreEnTxt(taille / 1024, 2, "") & " Kb"
    End If
End Function

Function NombreEnTxt$(num As Variant, x As Byte, TypeSep$, Optional mas As Boolean = False)
'Retranscrit un nombre en chaîne.
'Complète s'il le faut, avec des 0, un nombre décimal, de telle sorte qu'il y ait un nombre déterminé de chiffres après la virgule.
'Place éventuellement des séparateurs de milliers
'job75 / Magic_Doctor
'************************************************************************************************************************************
'- num     : un nombre
'- x       : le nombre de chiffres voulu après la virgule
'- TypeSep : si ""  --> pas de séparateurs de milliers (25145785 --> 25145785)
'            si " " --> espace (25145785 --> 25 145 785)
'            si "." --> point  (25145785 --> 25.145.785)
'- mas     : si True : si le nombre est positif, alors il sera précédé du signe "+"
'Exemple   : si x = 2 & sep = True ou omis => num = 2               --> 2,00
'                                             num = 125752,22       --> 125.752,22
'                                             num = -202454524565,5 --> -202.454.524.565,50
'            si x = 5 | sep = True | TypeSep = " " | mas = True => num = 125365875,25 --> +125 365 875,25000
'************************************************************************************************************************************

    Dim signe$, Txt$, i%, t$, n$, nb$, pos As Byte, gauche$, droite$, millier$

    On Error Resume Next 'pour que n'apparaisse pas #¡VALOR! si num = ""
    If num = "" Then Exit Function
    
    signe = IIf(num = Abs(num), IIf(mas, "+", ""), "-")
    
    num = FormatNumber(num, 15) 'pour éviter que ne s'impose la notation scientifique
    Txt = CStr(Abs(num))
    For i = 1 To Len(Txt)
        t = Mid(Txt, i, 1)
        If Not IsNumeric(t) And t <> "," And t <> "." Then Exit For
    Next
    t = Replace(Left(Txt, i - 1), ",", ".")
    n = IIf(i = 1, "", Format(Val(t), "0." & String(x, "0")))
    If x = 0 Then n = Replace(n, ",", "") 'pas de décimale après la virgule donc pas de virgule
    
    nb = n & Mid(Txt, i)
    pos = InStr(1, nb, ",")
    gauche = Left(nb, pos - 1)
    droite = Mid(nb, pos + 1)
    
    If TypeSep = "" Then  'pas de séparateurs de milliers
        NombreEnTxt = signe & n
    Else  'séparateurs de milliers (" " ou ".")
        If x = 0 Then  'nombre entier
            millier = IIf(TypeSep = " ", Replace(Format(Int(Abs(num)), "#,##0"), ".", Chr(160)), Replace(Format(Int(Abs(num)), "#,##0"), Chr(160), "."))
            NombreEnTxt = signe & millier
        Else  'nombre décimal
            millier = IIf(TypeSep = " ", Replace(Format(CDec(gauche), "#,##0"), ".", Chr(160)), Replace(Format(CDec(gauche), "#,##0"), Chr(160), "."))
            If InStr(gauche, Application.DecimalSeparator) Then millier = millier & Mid(gauche, InStr(gauche, Application.DecimalSeparator))
            NombreEnTxt = signe & millier & "," & droite
        End If
    End If
End Function

Sub BoucleFichiers()
    On Error GoTo Fin
    Dim Chemin$, Fichier$, Ligne%, T, DL%, TableauExtensions, T0
    T0 = Timer
    [A:D].ClearContents
    Application.ScreenUpdating = False
    Sheets.Add(after:=Sheets(Worksheets.Count)).Name = "OnBosse"
    Sheets("OnBosse").Select
    Chemin = "g:\Users\PC_PAPA\Documents"                                   ' A ADAPTER
    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"   ' Pour les étourdis.
    Ligne = 1
    ' Liste les fichiers
    Fichier = Dir(Chemin & "*.*")
    Do While Len(Fichier) > 0
        Cells(Ligne, "A") = Fichier
        Ligne = Ligne + 1
        Fichier = Dir()
    Loop
    ' Extrait les extensions
    For i = 1 To Range("A65500").End(xlUp).Row
        T = Split(Cells(i, "A"), "."): Cells(i, "B") = T(UBound(T))
    Next i
    DL = Range("B65500").End(xlUp).Row
    Range("C1:C" & DL) = Range("B1:B" & DL).Value
    Range("C1:C" & DL).RemoveDuplicates Columns:=1, Header:=xlNo
    DL = Range("C65500").End(xlUp).Row
    Range("D1:D" & DL).FormulaLocal = "=NB.SI(B:B;C1)"
    Range("D1:D" & DL) = Range("D1:D" & DL).Value
    TableauExtensions = Range("C1:D" & DL)
    Application.DisplayAlerts = False
    Sheets("OnBosse").Delete
    Application.DisplayAlerts = True
    
    '------------------------------------------------------------------------------------------
    ' JUSTE POUR LA DEMO, A SUPPRIMER
    [C:F].ClearContents
    [C5] = "Les données sont dans l'array TableauExtensions"
    [C7] = "Temps d'exécution = " & Round(1000 * (Timer - T0), 0) & " ms"
    [C9].Resize(UBound(TableauExtensions, 1), UBound(TableauExtensions, 2)) = TableauExtensions
    '------------------------------------------------------------------------------------------
Fin:
End Sub

Sub Extensions()
Dim Fichier$, Bur$
Dim Dico As Object
Dim TReport As Variant, Text As Variant

'Dossier listé : Bureau
Bur = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/"
Set Dico = CreateObject("scripting.dictionary")

Fichier = Dir(Bur & "*.*")
Do While Len(Fichier) > 0
    Text = Split(Fichier, ".")
    Dico("." & Text(UBound(Text))) = ""
    Fichier = Dir()
Loop
TReport = Application.Transpose(Dico.keys)
End Sub

Function Get_Extensions(Dossier)
Dim Fichier     As Variant
Dim Tab_Save    As Variant
Dim Tab_Trié    As Variant
Dim Fso         As Object
Dim Dico        As Object
Dim I           As Long
Dim J           As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
        Set Dico = CreateObject("scripting.dictionary")
            For Each Fichier In Fso.GetFolder(Dossier).Files
                Dico(Fso.GetExtensionName(Fichier)) = vbNullString
            Next
           ' tri de la table
            Tab_Trié = Dico.keys
            For I = LBound(Tab_Trié) To UBound(Tab_Trié) - 1
                For J = I + 1 To UBound(Tab_Trié)
                    If Tab_Trié(I) > Tab_Trié(J) Then
                        Tab_Save = Tab_Trié(J)
                        Tab_Trié(J) = Tab_Trié(I)
                        Tab_Trié(I) = Tab_Save
                    End If
                Next J
            Next I
            Get_Extensions = Tab_Trié
        Set Dico = Nothing
    Set Fso = Nothing
End Function

Function Get_Extensions(Dossier)
Dim Fichier  As Variant, Ext   As Variant
Dim Fso      As Object, Dico   As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Dico = CreateObject("System.Collections.ArrayList")
            For Each Fichier In Fso.GetFolder(Dossier).Files
                Ext = Fso.GetExtensionName(Fichier)
                If Not Dico.Contains(Ext) Then Dico.Add Ext
            Next
            Dico.Sort
            Get_Extensions = Dico.ToArray
        Set Dico = Nothing
    Set Fso = Nothing
End Function