MACRO VBA per unire due fogli con la stessa intestazione

Question

Buongiorno a tutti,

ho un file Excel composto da due fogli "Sheet1" e "Sheet2" strutturati nello stesso modo:

#	A	B	C	D
1	XXX	XXX	XXX	XXX
2	XXX	XXX	XXX	XXX
3	XXX	XXX	XXX	XXX

Vorrei creare una macro che:

1. crei nuova cartella di lavoro con un foglio "Consolida"
2. copi nel foglio "Consolida" i valori (no formule) dei fogli contenuti nel file originario
3. abbia come range tutte le colonne popolate (oggi sono 10 ma in futuro potrei aggiungere altri campi) e tutte le righe (numero variabile)

Grazie a tutti,

Andrea

Answer 1

Ciao Andrea,

Ho rimesso il codice della procedura Tester (ho aggiunto la linea per cominaciare dalla riga 7) ma mi produce una cartella (denominata "Foglio XX") con il foglio Consolidamento e tutte le celle vuote. La macro gira ma non mi produce più l'output di prima... Inoltre ho visto che me lo salva in una cartella (diversa da prima, sembra l'ultima cartella che ho aperta) ma non in quella segnalata nella procedura...

 Credo sia molto probabile che i tuoi problemi siano legati al fatto che tu abbia aggiunta la dichiarazione

    Const iRiga_Intestazioni As Long = 7               '<<=== Modifica

ma non hai apportato nessuna delle necessarie modifiche di conseguenza, cioè le modifiche indicate in grassetto da me nella mia risposta pertinente!

Quindi, prova invece:

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

Option Explicit

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

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, rHeaders As Range

    Dim arrFogli As Variant

    Dim sFileName As String

    Dim sPath As String, sStr As String

    Dim i As Long

    Dim iRow As Long, iCol As Long, jRow As Long

    Dim bHeaders As Boolean

    Const sFogliSorgenti As String = _

                                                "Foglio 1, Foglio 2"     '<<=== Modifica

    Const sFoglioDestinazione As String = _

                                                 "Consolidamento"     '<<=== Modifica

    Const sFileDestinazione = _

                             "Andrea_Consolidamento.xlsx"     '<<=== Modifica

    Const iRiga_Intestazioni As Long = 7                     '<<=== Modifica

    Const sPercoso_Salvataggio As String = _

                      "D:\Users\utente\Desktop\PROVA"      '<<=== Modifica

    Set srcWB = ThisWorkbook

    If Workbook_Exists(sFileDestinazione) Then

        If Not IsWorkBookOpen(sFileDestinazione) Then

            Set destWB = Workbooks.Open(sFileDestinazione)

        Else

            Set destWB = Workbooks(sFileDestinazione)

        End If

    Else

        Set destWB = Workbooks.Add(xlWBATWorksheet)

        'destWB.SaveAs fileName:=sFileDestinazione, FileFormat:=51

    End If

    With destWB

        If SheetExists(sFoglioDestinazione, destWB) Then

            Set destSH = .Sheets(sFoglioDestinazione)

            destSH.UsedRange.ClearContents

        Else

            Set destSH = .Sheets.Add(Before:=.Sheets(.Sheets.Count))

            destSH.Name = sFoglioDestinazione

        End If

    End With

    On Error GoTo XIT

    Application.ScreenUpdating = False

    arrFogli = Split(sFogliSorgenti, ",")

    For i = LBound(arrFogli) To UBound(arrFogli)

        Set srcSH = srcWB.Sheets(Trim(arrFogli(i)))

        Set rHeaders = srcSH.Rows(iRiga_Intestazioni)

        With srcSH

            iRow = LastRow(srcSH, .Columns("A:A"), iRiga_Intestazioni)

            iCol = LastCol(srcSH, .Rows(iRiga_Intestazioni))

            Set srcRng = .Range("A" & iRiga_Intestazioni + 1). _

                         Resize(iRow - iRiga_Intestazioni, iCol)

        End With

        With destSH

            If Not bHeaders Then

                rHeaders.Copy Destination:=.Range("A1")

                bHeaders = True

            End If

            jRow = LastRow(destSH, .Columns("A:A"))

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

        End With

        srcRng.Copy

        With destRng

            .PasteSpecial (xlPasteValuesAndNumberFormats)

            .PasteSpecial (xlPasteColumnWidths)

        End With

    Next i

    With destWB

        With .Styles("Normal").Font

            .Name = "Arial"

            .Size = 10

            .Bold = False

            .Italic = False

            .Underline = xlUnderlineStyleNone

            .Strikethrough = False

            .ThemeColor = 2

            .TintAndShade = 0

            .ThemeFont = xlThemeFontNone

        End With

        ActiveWindow.Zoom = 85

        sStr = Application.PathSeparator

        sPath = ThisWorkbook.Path & sStr

        If Right(sPercoso_Salvataggio, 1) = sStr Then

            sPath = sPercoso_Salvataggio

        Else

            sPath = sPercoso_Salvataggio & sStr

        End If

        sFileName = sPath _

                    & Format(Date, "yyyymmdd") _

                    & sFileDestinazione

        .SaveAs FileName:=sFileName, _

                FileFormat:=51

        .Close

    End With

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub

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

===

Regards,

Norman

Answer 2

Inoltre, ho visto che nel file aggregato vengono mantenuti formato e larghezza colonne. Come si fa, invece, a fare in modo che nel file di destinazione il carattere sia Arial e dimensione 10 su tutto il foglio (come sui due fogli iniziali)?

Questo non capisco! Nel modo in cui è stato scritto il codice, le dimensioni del testo e le larghezze delle colonne sono rispettate fidelmente nell'operazione di consolidamento. Più precisamente, qualora ci fosse stato applicato ai dati di origine un formato con caratteri arial e dimensione 10,  i dati nel foglio di consolidamento avrebbero il medesimo formato.

Nel mio caso quando apre il file nuovo è in Calibri 10 (font predefinito Excel). Se cambio nelle impostazioni il font predefinito e metto Arial 10 il formato nel foglio di consolidamento è identico al file.

Mi chiedevo se esistesse un comando per far mettere di default un carattere e una size predefinita.

Answer 3

Ciao Andrea,

grazie per il codice, funziona egregiamente!

Bene! Mi fa piacere.

Giusto per capire la logica, se la tabella non iniziasse in A1 e ma l'intestazione fosse in entrambi i fogli sulla riga 7 e le celle superiori non volessi copiarle, come potrei modificarlo (tendendo sempre il range variabie in base al numero di righe e colonne che ci sono nelle tabelle da copiare)?

Sostituisci la procedura Tester con la seguente versione in cui le modifiche sono evidenziate in grassetto:

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

Option Explicit

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

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, rHeaders As Range

    Dim arrFogli As Variant

    Dim i As Long

    Dim iRow As Long, iCol As Long, jRow As Long

    Dim bHeaders As Boolean

    Const sFogliSorgenti As String = _

                                           "Foglio1, Foglio2"          '<<=== Modifica

    Const sFoglioDestinazione As String = _

                                             "Consolidazione"         '<<=== Modifica

    Const sFileDestinazione = _

                        "Andrea_Consolidazione.xlsx"          '<<=== Modifica

Const iRiga_Intestazioni As Long = 7               '<<=== Modifica

    Set srcWB = ThisWorkbook

    If Workbook_Exists(sFileDestinazione) Then

        If Not IsWorkBookOpen(sFileDestinazione) Then

            Set destWB = Workbooks.Open(sFileDestinazione)

        Else

            Set destWB = Workbooks(sFileDestinazione)

        End If

    Else

        Set destWB = Workbooks.Add(xlWBATWorksheet)

        destWB.SaveAs FileName:=sFileDestinazione, FileFormat:=51

    End If

    With destWB

        If SheetExists(sFoglioDestinazione, destWB) Then

            Set destSH = .Sheets(sFoglioDestinazione)

            destSH.UsedRange.ClearContents

        Else

            Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count))

            destSH.Name = sFoglioDestinazione

        End If

    End With

    On Error GoTo XIT

    Application.ScreenUpdating = False

    arrFogli = Split(sFogliSorgenti, ",")

    For i = LBound(arrFogli) To UBound(arrFogli)

        Set srcSH = srcWB.Sheets(Trim(arrFogli(i)))

        Set rHeaders = srcSH.Rows(iRiga_Intestazioni)

        With srcSH

            iRow = LastRow(srcSH, .Columns("A:A"), iRiga_Intestazioni)

            iCol = LastCol(srcSH, .Rows(iRiga_Intestazioni))

            Set srcRng = .Range("A" & iRiga_Intestazioni + 1). _

                         Resize(iRow - iRiga_Intestazioni, iCol)

        End With

        With destSH

            If Not bHeaders Then

                rHeaders.Copy Destination:=.Range("A1")

                bHeaders = True

            End If

            jRow = LastRow(destSH, .Columns("A:A"))

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

        End With

        srcRng.Copy

        With destRng

            .PasteSpecial (xlPasteAll)

            .PasteSpecial (xlPasteColumnWidths)

        End With

    Next i

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub

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

Inoltre, ho visto che nel file aggregato vengono mantenuti formato e larghezza colonne. Come si fa, invece, a fare in modo che nel file di destinazione il carattere sia Arial e dimensione 10 su tutto il foglio (come sui due fogli iniziali)?

Questo non capisco! Nel modo in cui è stato scritto il codice, le dimensioni del testo e le larghezze delle colonne sono rispettate fidelmente nell'operazione di consolidamento. Più precisamente, qualora ci fosse stato applicato ai dati di origine un formato con caratteri arial e dimensione 10,  i dati nel foglio di consolidamento avrebbero il medesimo formato.

===

Regards,

Norman

Answer 4

Ciao Norman,

grazie per il codice, funziona egregiamente!

Giusto per capire la logica, se la tabella non iniziasse in A1 e ma l'intestazione fosse in entrambi i fogli sulla riga 7 e le celle superiori non volessi copiarle, come potrei modificarlo (tendendo sempre il range variabie in base al numero di righe e colonne che ci sono nelle tabelle da copiare)?

Inoltre, ho visto che nel file aggregato vengono mantenuti formato e larghezza colonne. Come si fa, invece, a fare in modo che nel file di destinazione il carattere sia Arial e dimensione 10 su tutto il foglio (come sui due fogli iniziali)?

Ti ringrazio nuovamente,

Andrea

Answer 5

Ciao Andrea,

ho un file Excel composto da due fogli "Sheet1" e "Sheet2" strutturati nello stesso modo:

#	A	B	C	D
1	XXX	XXX	XXX	XXX
2	XXX	XXX	XXX	XXX
3	XXX	XXX	XXX	XXX

Vorrei creare una macro che:

1. crei nuova cartella di lavoro con un foglio "Consolida"
2. copi nel foglio "Consolida" i valori (no formule) dei fogli contenuti nel file originario
3. abbia come range tutte le colonne popolate (oggi sono 10 ma in futuro potrei aggiungere altri campi) e tutte le righe (numero variabile)

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per 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 srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, rHeaders As Range

    Dim arrFogli As Variant

    Dim i As Long

    Dim iRow As Long, iCol As Long, jRow As Long

    Dim bHeaders As Boolean

    Const sFogliSorgenti As String = _

                                          "Foglio1, Foglio2"     '<<=== Modifica

    Const sFoglioDestinazione As String = _

                                           "Consolidazione"     '<<=== Modifica

    Const sFileDestinazione = _

                     "Andrea_Consolidazione.xlsx"     '<<=== Modifica

    Set srcWB = ThisWorkbook

    If Workbook_Exists(sFileDestinazione) Then

        If Not IsWorkBookOpen(sFileDestinazione) Then

            Set destWB = Workbooks.Open(sFileDestinazione)

        Else

            Set destWB = Workbooks(sFileDestinazione)

        End If

    Else

        Set destWB = Workbooks.Add(xlWBATWorksheet)

        destWB.SaveAs FileName:=sFileDestinazione, FileFormat:=51

    End If

    With destWB

        If SheetExists(sFoglioDestinazione, destWB) Then

            Set destSH = .Sheets(sFoglioDestinazione)

            destSH.UsedRange.ClearContents

        Else

            Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count))

            destSH.Name = sFoglioDestinazione

        End If

    End With

    On Error GoTo XIT

    Application.ScreenUpdating = False

    arrFogli = Split(sFogliSorgenti, ",")

    For i = LBound(arrFogli) To UBound(arrFogli)

        Set srcSH = srcWB.Sheets(Trim(arrFogli(i)))

        Set rHeaders = srcSH.Rows(1)

        With srcSH

            iRow = LastRow(srcSH, .Columns("A:A"))

            iCol = LastCol(srcSH, .Rows(1))

            Set srcRng = .Range("A2").Resize(iRow - 1, iCol)

        End With

        With destSH

            If Not bHeaders Then

                rHeaders.Copy Destination:=.Range("A1")

                bHeaders = True

            End If

            jRow = LastRow(destSH, .Columns("A:A"))

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

        End With

        srcRng.Copy

        With destRng

            .PasteSpecial (xlPasteAll)

            .PasteSpecial (xlPasteColumnWidths)

        End With

    Next i

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub

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

Public Function Workbook_Exists(sFile As String, _

                                Optional sFolderPath As Variant) As Boolean

    Dim oFSO As Object

    Dim sPath As String

    Dim sSeparator As String

    sSeparator = Application.PathSeparator

    If IsMissing(sFolderPath) Then

        sPath = ThisWorkbook.Path & sSeparator

    Else

        If Right(sFolderPath, 1) = sSeparator Then

            sPath = sFolderPath

        Else

            sPath = sFolderPath & sSeparator

        End If

    End If

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Workbook_Exists = oFSO.FileExists(sPath & sFile)

End Function

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

Public Function IsWorkBookOpen(ByRef sWbName As String) As Boolean

    On Error Resume Next

    IsWorkBookOpen = Not (Application.Workbooks(sWbName) Is Nothing)

End Function

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

Public Function SheetExists(sSheetName As String, _

                            Optional ByVal WB As Workbook) As Boolean

    On Error Resume Next

    If WB Is Nothing Then

        Set WB = ThisWorkbook

    End If

    SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))

    On Error GoTo 0

End Function

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

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

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

Public Function LastCol(SH As Worksheet, _

                        Optional Rng As Range, _

                        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

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

                       After:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByColumns, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Column

    On Error GoTo 0

    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

===

Regards,

Norman