Sub SalvaFogli()
Dim n As Long
Dim myNome As String
Dim myPath As String

myPath = "C:Temp"     'da modificare
With ActiveWorkbook
    For n = 1 To .Sheets.Count
        myNome = .Sheets(n).Name
        .Sheets(n).Copy
    
        ActiveWorkbook.SaveAs Filename:=myPath & myNome
        ActiveWorkbook.Close
    Next n
End With
MsgBox "Sono stati creati " & n - 1 & " files"

End Sub

Function SeparaFogli(strPath, File)
'@@utilities@@ i fogli contenuti in una cartella xls diventano singoli file xls (chiede dove salvarli)
Dim ChDir, NomeFile, StrCartella, Vuoi As String
Workbooks.Open Filename:=strPath & "" & File
NomeF = ActiveWorkbook.Name
   MsgBox (NomeF)
   
ChDir = ActiveWorkbook.Path
    Vuoi = MsgBox("Salvo in questa Cartella->" & ChDir & "?", vbYesNo)
 
    If Vuoi = vbNo Then
    On Error Resume Next
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
       
        If .Show = False Then
        Exit Function
        End If
        StrCartella = .SelectedItems(1)
        End With
    If StrCartella <> "" Then
    ChDir = StrCartella
    End If
    End If
   
For g = 1 To Sheets.Count

   Worksheets(g).Activate
    ActiveSheet.Select
    ActiveSheet.Copy
NomeFile = NomeF & "_" & ActiveSheet.Name & ".xls"



    ActiveWorkbook.SaveAs Filename:=ChDir & "" & NomeFile _
        , FileFormat:=xlNormal, password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        
ActiveWorkbook.Close
    Windows(NomeF).Activate
    Next
    ActiveWorkbook.Close
End Function
Sub ElencaFile()
' Elenca tutti i file in una cartella
Dim objFso, objFolder, objFiles, strFolder, strFile
' impostare qui la cartella desiderata
strPath = "c:prova"
     
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strPath)
Set objFiles = objFolder.Files

For Each strFile In objFiles

c = SeparaFogli(strPath, strFile.Name)
 
   
Next
  
Set objFso = Nothing
Set objFolder = Nothing
Set objFiles = Nothing

End Sub

Function SeparaFogli(strPath, File, NuovaCartella)
'@@utilities@@ i fogli contenuti in una cartella xls diventano singoli file xls (chiede dove salvarli)
Dim ChDir, NomeFile, StrCartella, Vuoi As String
'apre il file presente a questo indirizzo
Workbooks.Open Filename:=strPath & "" & File
NomeF = ActiveWorkbook.Name
 '  MsgBox (NomeF)
   

   
For g = 1 To Sheets.Count

   Worksheets(g).Activate
    ActiveSheet.Select
    ActiveSheet.Copy
NomeFile = NomeF & "_" & ActiveSheet.Name & ".xls"


' cartella in cui salvare i diversi fogli come file xls
    ActiveWorkbook.SaveAs Filename:=strPath & "" & NuovaCartella & "" & NomeFile _
        , FileFormat:=xlNormal, password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        
ActiveWorkbook.Close
    Windows(NomeF).Activate
    Next
    ActiveWorkbook.Close
End Function
Sub ElencaFile()
' Elenca tutti i file in una cartella
Dim objFso, objFolder, objFiles, strFolder, strFile, ChDir, NomeFile, StrCartella, Vuoi

ChDir = ActiveWorkbook.Path
' qui la macro chiede qual e' la cartella da selezionare
    Vuoi = MsgBox("Cartella in cui si trovano i file xls->" & ChDir & "?", vbYesNo)
 
    If Vuoi = vbNo Then
    On Error Resume Next
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    With FD
       
        If .Show = False Then
        Exit Sub
        End If
        strPath = .SelectedItems(1)
        End With
    If strPath <> "" Then
    ChDir = strPath
    End If
    End If
     
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(ChDir)
Set objFiles = objFolder.Files



i = 0
For Each strFile In objFiles
' mi ricavo il nome del file senza xls finale per creare le cartelle
cd = Split(strFile.Name, ".")
' VERIFICO CHE SIA UN FILE XLS PRIMA DI PROCEDERE
    If cd(UBound(cd)) = "xls" Then
            NomeCart = cd(0)
        d = Crea_Cartella(ChDir, NomeCart)
        c = SeparaFogli(ChDir, strFile.Name, NomeCart)
                i = i + 1
    End If
Next
MsgBox (" Processati " & i & " File xls")
Set objFso = Nothing
Set objFolder = Nothing
Set objFiles = Nothing

End Sub

Function Crea_Cartella(Path, NomeCartella)
            Set fso = CreateObject("Scripting.FileSystemObject")
            Cartella = Path & "" & NomeCartella
            If Not fso.FolderExists(Cartella) Then
            fso.CreateFolder (Cartella)
            End If
End Function

If ActiveSheet.Name Like ("blocco*") Then

Function SeparaFogli(strPath, File, NuovaCartella)
'@@utilities@@ i fogli contenuti in una cartella xls diventano singoli file xls (chiede dove salvarli)
Dim ChDir, NomeFile, StrCartella, Vuoi As String
'apre il file presente a questo indirizzo
Workbooks.Open Filename:=strPath & "" & File
NomeF = ActiveWorkbook.Name
 '  MsgBox (NomeF)
   

   
For g = 1 To Sheets.Count

   Worksheets(g).Activate

If ActiveSheet.Name Like ("BLOCCO*") Then 'Estraggo solo i fogli il cui nome inizia con BLOCCO
 

    ActiveSheet.Select
    ActiveSheet.Copy
NomeFile = NomeF & "_" & ActiveSheet.Name & ".xls"


' cartella in cui salvare i diversi fogli come file xls
    ActiveWorkbook.SaveAs Filename:=strPath & "" & NuovaCartella & "" & NomeFile _
        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        
ActiveWorkbook.Close
    Windows(NomeF).Activate

End if

    Next
    ActiveWorkbook.Close
End Function