Attribute VB_Name = "Modulo_RiunisceTuttiFogli"
' Il nome del corrente modulo VBA (Visual Basic for Application)
' deve iniziare con i caratteri "Modulo" ed avere estensione ".bas".
' Per importarlo dentro un Excel 2007 ".xlsm" (con macro attivate), esegui
'    Sviluppo, Visual Basic, File, Importa file...
' e, infine, scegli il file corrente dalla finestra di importazione.

Sub RiunisceTuttiFogli()
Attribute RiunisceTuttiFogli.VB_ProcData.VB_Invoke_Func = " \n14"

'La presente Subroutine copia come fogli propri tutti i fogli di tutte le cartelle excel (*.xls*)
'presenti nello stesso indirizzario di residenza.
'Essendo nata sopra cartelle con collegamenti rinfrescabili, se ne preoccupa evitando
'di costringere l'utente a rispondere ai messaggi di richiesta.

Dim FoglioDiAvvio As Worksheet
Dim NomeFoglio As String
Dim IndirizzarioDatore As String
Dim CartellaRicevente As String
Dim CartellaDatrice As String
Dim FoglioRicevente31 As String
Dim CartellaDatriceQualificata As String
Dim CartellaDatriceGenerica As String
Dim Foglio As Worksheet
Dim Contatore As Integer

On Error GoTo RigaErrore

' --> Digita qui il nome generico delle cartelle datrici da ammucchiare nel foglio ricevente.
CartellaDatriceGenerica = "*.xls*"

'Annota l'indirizzario del file corrente
'che contiene anche le cartelle datrici da ammucchiare nel foglio ricevente.
IndirizzarioDatore = ActiveWorkbook.Path

'Annota il nome della cartella ricevente.
CartellaRicevente = ActiveWorkbook.Name

'Annota il nome del foglio di avvio.
Set FoglioDiAvvio = Worksheets(ActiveSheet.Name)

'Non aggiorna il video per non rallentare l'elaborazione.
Application.ScreenUpdating = True
  
'Elenca i file Excel da ammucchiare nel foglio ricevente.
CartellaDatrice = Dir(IndirizzarioDatore & "\" & CartellaDatriceGenerica)

'Esegue su tutti i file Excel elencati.
Do While Len(CartellaDatrice) > 0
    'Se la cartella datrice corrente non è la ricevente.
    If CartellaDatrice <> CartellaRicevente Then
        'Elabora il singolo file Excel.
  
        'Compone il nome qualificato del file Excel datore.
        CartellaDatriceQualificata = IndirizzarioDatore & "\" & CartellaDatrice
        
        'Apre il file Excel datore.
        'Visto che in Office2007 UpdateLinks:=xlUpdateLinksNever pare non funzionare,
        'prima dell'esecuzione disinnesca la messaggistica, poi la reinserisce.
        Application.DisplayAlerts = False
        Workbooks.Open Filename:=CartellaDatriceQualificata, UpdateLinks:=xlUpdateLinksNever
        Application.DisplayAlerts = True
        'Azzera contatore fogli nella cartella
        Contatore = 0
        
        'Per ogni foglio della cartella
        For Each Foglio In ActiveWorkbook.Worksheets
            
            'Annota foglio datore.
            NomeFoglio = Foglio.Name
            'Incrementa il contatore fogli nella cartella.
            Contatore = Contatore + 1
            'Accorcia il nome della cartella datrice.
            FoglioRicevente31 = Left(CartellaDatrice, 29) & Contatore
        
            'Ritorna sulla cartella datrice.
            Windows(CartellaDatrice).Activate
            'Copia il foglio datore.
            Sheets(NomeFoglio).Select
            Sheets(NomeFoglio).Copy After:=Workbooks(CartellaRicevente).Sheets(1)
        
            'Rifocalizza il foglio ricevente e lo rinomina col nome accorciato.
            Sheets(NomeFoglio).Name = FoglioRicevente31
        
        'Per ogni foglio della cartella
        Next
        
        'Ritorna sulla cartella datrice e la chiude evitando di aggiornare.
        Windows(CartellaDatrice).Activate
        ActiveWindow.Close SaveChanges:=False
        
    'Se la cartella datrice corrente non è la ricevente.
    End If
    
    'Estrae il prossimo nome del file datore.
    CartellaDatrice = Dir()
    
'Esegue su tutti i file Excel elencati.
Loop

'Ritorna sulla cartella datrice.
Windows(CartellaRicevente).Activate
'Focalizza il foglio di avvio.
Sheets(FoglioDiAvvio.Name).Activate

RigaChiusura:

With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

Exit Sub

RigaErrore:

MsgBox Err.Number & vbNewLine & Err.Description
Resume RigaChiusura

End Sub