Sub ShowFolderList(CARTELLA, rig, col)
'CARTELLA=Cartella sorgente
'rig=Riga del foglio di output
'col=Colonna del foglio di output
   
    Dim fs, f, F1, s, sf
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.getfolder(CARTELLA)
    Set sf = f.SubFolders
    Set fails = f.Files
    nomedisco = f.drive.volumename '**** etichetta del 

disco
   
    '***** controllo tutti i files della cartella 

*******
    For Each pf1 In fails
        If pf1.Name = "" Then GoTo avanti  '**se la 

cartella non contiene nomi di file
        On Error GoTo pross
        nomedisco = f.drive.volumename
        Percorso = Right(pf1.parentfolder.Path, 

Len(pf1.parentfolder.Path) - 2)
        NomeFile = pf1.Name
        estens = Right(NomeFile, 3)
        dimens = pf1.Size
        datacre = pf1.DateCreated 'data creazione File
        dataultacc = pf1.DateLastAccessed 'data ultimo 

accesso al file
        dataultmod = pf1.DateLastModified 'data ultima 

modifica al file
        Cells(rig, col + 1) = CARTELLA
        Cells(rig, col + 2) = NomeFile
        Cells(rig, col + 3) = estens
        Cells(rig, col + 4) = datacre
        Cells(rig, col + 5) = dimens
        Cells(rig, col + 6) = dataultacc
        Cells(rig, col + 7) = dataultmod
        rig = rig + 1
        Cells(1, 2) = "numfile=" & Str(rig - 2)
pross:
    Next

'****** controllo se la cartella contiene sottocartelle
avanti:
    For Each F1 In sf
        If F1.Name = "" Then GoTo sotto ' *** se la 

cartella non contiene sottocartelle
        On Error GoTo sotto
        Cells(1, 3) = CARTELLA & "" & F1.Name
       
        Call ShowFolderList(CARTELLA & "" & F1.Name, 

rig, col) '***** chiamata ricorsiva
sotto:
    Next
End Sub



'***** sub da associare ad un tasto rapido *****
Sub Tastopremuto()
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    Range("A2:Z3000").ClearContents
    patte = Cells(1, 1)
    Call ShowFolderList(patte, 2, 2)
    MsgBox ("FINITO")
End Sub

Sub Salva_Copia()
    On Error GoTo gest_err
    
    Application.DisplayAlerts = False
    Nome_Attuale = ActiveWorkbook.Name
    Percorso = [D1]
    NomeFile = Mid(Nome_Attuale, 1, Len(Nome_Attuale) - 4) + " " & Format(Date, "dd mmm yyyy") & ".XLS"
    ActiveWorkbook.SaveCopyAs Percorso & "" & NomeFile
    Application.DisplayAlerts = True
    
    Exit Sub
    
gest_err:
    If Err.Number = 1004 Then MkDir [D1]
    Resume
End Sub

Sub Ordina()
'
' Ordina Macro
' Macro registrata il 26/09/2013 da Marcello
''
    Cells.Select
    Range("P1").Activate
    Selection.Sort Key1:=Range("T2"), Order1:=xlAscending, Key2:=Range("U2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal
    ActiveWindow.SmallScroll ToRight:=15
    Columns("S:S").Select
    Selection.Copy
    Columns("W:W").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Cells.Select
    Range("P1").Activate
    Application.CutCopyMode = False

End Sub

Sub Ordina()
'
' Ordina Macro
' Macro registrata il 26/09/2013 da Marcello

    Range("P1").Sort Key1:=Range("T2"), Order1:=xlAscending, Key2:=Range("U2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal

    'ActiveWindow.SmallScroll ToRight:=15      '<-- questa riga è inutile

    Columns("S:S").Copy 
    Columns("W:W").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
    Application.CutCopyMode = False

End Sub