Macro VBA per consolidare più fogli di una cartella di lavoro in un unico foglio su un’altra cartella

Question

Buongiorno a tutti,

ho una cartella di lavoro che si presenta in tanti fogli (circa 60), che sono strutturati nello stesso modo e si chiamano in modo diverso. L’ultimo foglio è di riepilogo con dei collegamenti ipertestuali ai diversi fogli.

Io vorrei creare una macro (in una nuova cartella di lavoro) che:

• legga questo file all’interno della directory senza aprirlo;
• aggreghi tutti i fogli di questa cartella (ad esclusione del foglio “Indice”) in un unico foglio;
• mantenga l’intestazione delle colonne del primo foglio (che si trovano sulle righe 10-11-12) possibilmente con la stessa larghezza delle colonne;
• copi con la formattazione tutti i campi contenuti dalla cella B13 (fissa) alla colonna AV (il numero di righe è variabile per foglio); vorrei escludere il foglio “Indice”.

Ho allegato un file esempio per rendere più chiara l’idea.

https://1drv.ms/x/s!AlI4xolvxTX\_hlDvYonJoestuoEP

Vi ringrazio,

Andrea

Answer 1

Ciao Andrea,

Grazie di nuovo Norman, molto utile vedere come cambia il codice.

La cella B10 viene copiata in ogni riga nella colonna B e non nella colonna E ma va bene lo stesso. Posso copiare il valore tutto in maiuscolo?

Prova:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim rDati As Range, rHeaders As Range, rDest As Range

    Dim iRow As Long, jRow As Long

    Dim CalcMode As Long

    Dim bHeader As Boolean

    Const sFile As String = _

          "20180703_Esempio_Consolida.xlsx"              '<<=== Modifica

    Const sFoglioDaEscludere As String = "Indice"    '<<=== Modifica

    Const sColonne As String = "A:AV"                       '<<=== Modifica

    On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set srcWB = Workbooks.Open(sFile)

    Set destWB = ThisWorkbook

    Set destSH = destWB.Sheets(1)

    For Each SH In srcWB.Worksheets

        With SH

            If .Name <> sFoglioDaEscludere Then

                If Not bHeader Then

                    Set rHeaders = Intersect(.Rows("10:12"), .Columns(sColonne))

                    rHeaders.Copy

                    With destSH.Range("A10")

                        .PasteSpecial (xlPasteAll)

                        .PasteSpecial (xlPasteColumnWidths)

                    End With

                    bHeader = True

                End If

                iRow = LastRow(SH, .Columns(sColonne), 13)

                With destSH

                    jRow = LastRow(destSH, .Columns(sColonne), 12)

                    Set rDest = .Range("A" & jRow + 1)

                End With

                Set rDati = Intersect(.Rows("13:" & iRow), .Columns(sColonne))

                rDati.Copy Destination:=rDest

                rDest.Resize(rDati.Rows.Count).Value = UCase(.Name**)**

            End If

        End With

    Next SH

With destSH

.Columns(1).Copy

.Columns(5).Insert Shift:=xlToRight

.Columns(5).AutoFit

.Columns(1).ClearContents

End With

    srcWB.Close SaveChanges:=False

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

'<<=========

===

Regards,

Norman

Answer 2

Grazie di nuovo Norman, molto utile vedere come cambia il codice.

La cella B10 viene copiata in ogni riga nella colonna B e non nella colonna E ma va bene lo stesso. Posso copiare il valore tutto in maiuscolo?

Answer 3

Ciao Andrea,

Perfetto Norman, grazie mille funziona!

Prego!

Mi è venuta in mente una piccola modifica per non perdere informazioni: vorrei inserire una colonna (prima della E) che contenga il nome del foglio (la cella B10 che è unita) per ogni riga. Posso modificare la macro attuale?

Se ho capito la tua esigenza, prova la seguente adattamento del codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim rDati As Range, rHeaders As Range, rDest As Range

    Dim iRow As Long, jRow As Long

    Dim CalcMode As Long

    Dim bHeader As Boolean

    Const sFile As String = _

          "20180703_Esempio_Consolida.xlsx"            '<<=== Modifica

    Const sFoglioDaEscludere As String = "Indice"     '<<=== Modifica

    Const sColonne As String = "A:AV"                        '<<=== Modifica

    On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set srcWB = Workbooks.Open(sFile)

    Set destWB = ThisWorkbook

    Set destSH = destWB.Sheets(1)

    For Each SH In srcWB.Worksheets

        With SH

            If .Name <> sFoglioDaEscludere Then

                If Not bHeader Then

                    Set rHeaders = Intersect(.Rows("10:12"), .Columns(sColonne))

                    rHeaders.Copy

                    With destSH.Range("A10")

                        .PasteSpecial (xlPasteAll)

                        .PasteSpecial (xlPasteColumnWidths)

                    End With

                    bHeader = True

                End If

                iRow = LastRow(SH, .Columns(sColonne), 13)

                With destSH

                    jRow = LastRow(destSH, .Columns(sColonne), 12)

                    Set rDest = .Range("A" & jRow + 1)

                End With

                Set rDati = Intersect(.Rows("13:" & iRow), .Columns(sColonne))

                rDati.Copy Destination:=rDest

                rDest.Resize(rDati.Rows.Count).Value = .Name

            End If

        End With

    Next SH

With destSH

.Columns(1).Insert

.Columns(1).ColumnWidth = .Columns(2).ColumnWidth

.Columns(2).AutoFit

End With

    srcWB.Close SaveChanges:=False

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

'<<=========

===

Regards,

Norman

Answer 4

Perfetto Norman, grazie mille funziona!

Mi è venuta in mente una piccola modifica per non perdere informazioni: vorrei inserire una colonna (prima della E) che contenga il nome del foglio (la cella B10 che è unita) per ogni riga. Posso modificare la macro attuale?

Un saluto,

Andrea

Answer 5

Ciao Andrea,

ho una cartella di lavoro che si presenta in tanti fogli (circa 60), che sono strutturati nello stesso modo e si chiamano in modo diverso. L’ultimo foglio è di riepilogo con dei collegamenti ipertestuali ai diversi fogli. 

Io vorrei creare una macro (in una nuova cartella di lavoro) che:

• legga questo file all’interno della directory senza aprirlo;
• aggreghi tutti i fogli di questa cartella (ad esclusione del foglio “Indice”) in un unico foglio;
• mantenga l’intestazione delle colonne del primo foglio (che si trovano sulle righe 10-11-12) possibilmente con la stessa larghezza delle colonne;
• copi con la formattazione tutti i campi contenuti dalla cella B13 (fissa) alla colonna AV (il numero di righe è variabile per foglio); vorrei escludere il foglio “Indice”.

Ho allegato un file esempio per rendere più chiara l’idea.

https://1drv.ms/x/s!AlI4xolvxTX\_hlDvYonJoestuoEP

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IMper inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim rDati As Range, rHeaders As Range, rDest As Range

    Dim iRow As Long, jRow As Long

    Dim CalcMode As Long

    Dim bHeader As Boolean

    Const sFile As String = _

          "20180703_Esempio_Consolida.xlsx"         '<<=== Modifica

    Const sFoglioDaEscludere As String = "Indice"  '<<=== Modifica

    Const sColonne As String = "A:AV"                   '<<=== Modifica

       On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set srcWB = Workbooks.Open(sFile)

    Set destWB = ThisWorkbook

    Set destSH = destWB.Sheets(1)

    For Each SH In srcWB.Worksheets

        With SH

            If .Name <> sFoglioDaEscludere Then

                If Not bHeader Then

                    Set rHeaders = Intersect(.Rows("10:12"), .Columns(sColonne))

                    rHeaders.Copy

                    With destSH.Range("A10")

                        .PasteSpecial (xlPasteAll)

                        .PasteSpecial (xlPasteColumnWidths)

                    End With

                    bHeader = True

                End If

                iRow = LastRow(SH, .Columns(sColonne), 13)

                With destSH

                    jRow = LastRow(destSH, .Columns(sColonne), 12)

                    Set rDest = .Range("A" & jRow + 1)

                End With

                Set rDati = Intersect(.Rows("13:" & iRow), .Columns(sColonne))

                rDati.Copy Destination:=rDest

            End If

        End With

    Next SH

    srcWB.Close SaveChanges:=False

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

'<<========= 

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester
• Esegui

Nota che questo codice apre il file sorgente ma in modo nascosto. A meno che tu non abbia un buon motivo per cui il file non dovrebbe essere aperto, io no vorrei prendere in considerazione altri approcci.

===

Regards,

Norman