Attribute VB_Name = "Modulo_RiunisceFogli"
' 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 o 2010 ".xlsm" (con macro attivate), esegui
'    Sviluppo, Visual Basic, File, Importa file...
' e, infine, scegli il file corrente dalla finestra di importazione.

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

'La presente Subroutine copia come fogli propri i primi fogli di tutte le cartelle excel (*.xls*)
'presenti nello stesso indirizzario di residenza.
'Le cartelle datrici vengono aperte senza rinfrescare i collegamenti.
'Perché i messaggi funzionino, la cartella deve contenere UserForm1 contenente solo Label1.

Dim FoglioDiAvvio As Worksheet
Dim IndirizzarioDatore As String
Dim CartellaDatrice As String
Dim CartellaDatrice31 As String
Dim CartellaDatriceQualificata As String
Dim CartellaDatriceGenerica As String
Dim TitoloMessaggio1 As String
Dim TestoMessaggio1 As String
Dim TitoloMessaggio2 As String
Dim TestoMessaggio2 As String

On Error GoTo RigaErrore

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

'Testo dei Messaggi.
TitoloMessaggio1 = "ATTENDI..."
TestoMessaggio1 = "ELABORAZIONE DELLA MACRO IN CORSO..."
TitoloMessaggio2 = "FINE"
TestoMessaggio2 = "ELABORAZIONE DELLA MACRO TERMINATA"

'Messaggio di attesa on.
UserForm1.Caption = TitoloMessaggio1
UserForm1.Label1.Caption = TestoMessaggio1
UserForm1.Show vbModeless
DoEvents

'Annota l'indirizzario corrente che contiene anche le cartelle datrici da ammucchiare nella 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)

'True:  Aggiorna il video.
'False: 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 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 senza rinfrescare i collegamenti.
        'Funziona "UpdateLinks:=0" ma non "UpdateLinks:=xlUpdateLinksNever".
        Workbooks.Open Filename:=CartellaDatriceQualificata, UpdateLinks:=0
        
        'Annota foglio datore.
        NomeFoglio = ActiveSheet.Name
        
        'Accorcia il nome della cartella datrice.
        CartellaDatrice31 = Left(CartellaDatrice, 31)
        
        'Copia il foglio datore.
        Sheets(NomeFoglio).Select
        Sheets(NomeFoglio).Copy After:=Workbooks(CartellaRicevente).Sheets(1)
        
        'Ritorna sulla cartella datrice e la chiude evitando di aggiornare.
        Windows(CartellaDatrice).Activate
        ActiveWindow.Close SaveChanges:=False
        
        'Rifocalizza il foglio ricevente e lo rinomina col nome accorciato.
        Sheets(ActiveSheet.Name).Name = CartellaDatrice31
        
        'Focalizza l'angolo superiore sinistro.
        Range("A1").Select
                
    'Se la datrice corrente non è la ricevente.
    End If
    
    'Estrae il prossimo nome del file datore.
    CartellaDatrice = Dir()
    
'Esegue su tutti i file Excel elencati.
Loop

'GESTIONE CHIUSURA ED ERRORI.
RigaChiusura:

'Messaggio di attesa off.
Unload UserForm1
'Messaggio di fine on.
UserForm1.Caption = TitoloMessaggio2
UserForm1.Label1.Caption = TestoMessaggio2
UserForm1.Show
DoEvents
'Messaggio di fine off.
Unload UserForm1

'Sceglie il foglio di avvio.
FoglioDiAvvio.Select

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

Exit Sub

RigaErrore:

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

End Sub