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

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...

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"

    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(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 (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

        End With

        Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub

Answer 3

Ciao Andrea,

grazie delle dritte e il tuo contributo fondamentale. Il codice funziona molto bene.

Ho fatto qualche piccola modifica perchè mi serviva lo zoom a 85% e 

[...]

    With Worksheets

    .Select

    ActiveWindow.Zoom = 85

    End With

Evita la selezione che non è né efficiente né necessario e sostitiusci le tue quattro righe di codice con:

     ActiveWindow.Zoom = 85

Poi ho messo

With destRng

            .PasteSpecial (xlPasteValuesAndNumberFormats)

            .PasteSpecial (xlPasteColumnWidths)

        End With

perchè non volevo le formule sottostanti nei due fogli sorgente.

OK.

Mi sono sorte due domande:

1. ho visto che il file viene salvato automaticamente in Raccolte\Documenti ma non trovo il punto in cui gli viene dato questo comando. Si può inserire una directory specifica (es.C/utente/Prova) dove salvare il file?

In assenza della precisazione di un percorso esplicito, il file verrà automaticamente salvato nella directory predefinita attiva, Per salvare il file altrove, bisogna presiare il percorso di interesse. a proposito, credo che tu intendessi:

C:*utente*Prova**

1. ho cercato di modificare il nome file in modo automatico secondo la formattazione "YYYYMMMDD_Consolidamento" mettendo la funzione  Format(Now, "yyddmm") ma non funziona. E' una cosa fattibile?

Per rispondere a tutti i punti sollevati da te, sostituisci il codice della procedura Testercon la seguente versione:

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

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 = _

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

    Const sFoglioDestinazione As String = _

                                                     "Consolidamento"   '<<=== Modifica

    Const sFileDestinazione = _

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

    Const sPercoso_Salvataggio As String = _

                                  "C:\Users\Andrea\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(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 (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

    End With

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub

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

===

Regards,

Norman

Answer 4

Ciao Norman,

grazie delle dritte e il tuo contributo fondamentale. Il codice funziona molto bene.

Ho fatto qualche piccola modifica perchè mi serviva lo zoom a 85% e

with destWB.Styles("Normal").Font

        .Name = "Arial"

        .Size = 10

        .Bold = False

        .Italic = False

        .Underline = xlUnderlineStyleNone

        .Strikethrough = False

        .ThemeColor = 2

        .TintAndShade = 0

        .ThemeFont = xlThemeFontNone

    End With

    With Worksheets

    .Select

    ActiveWindow.Zoom = 85

    End With

Poi ho messo

With destRng

            .PasteSpecial (xlPasteValuesAndNumberFormats)

            .PasteSpecial (xlPasteColumnWidths)

        End With

perchè non volevo le formule sottostanti nei due fogli sorgente.

Mi sono sorte due domande:

1. ho visto che il file viene salvato automaticamente in Raccolte\Documenti ma non trovo il punto in cui gli viene dato questo comando. Si può inserire una directory specifica (es.C/utente/Prova) dove salvare il file?
2. ho cercato di modificare il nome file in modo automatico secondo la formattazione "YYYYMMMDD_Consolidamento" mettendo la funzione  Format(Now, "yyddmm") ma non funziona. E' una cosa fattibile?

Di nuovo grazie,

Andrea

Answer 5

Ciao Andea,

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. 

Rimango convinto che il testo copiato nel file di consolidamento avrà esattamente lo stesso formato di quello dei dati di origine.

Detto questo, qualsiasi cella sul foglio di consolidamento al di fuori dell'intervallo dei dati copiati sarà soggetta al formato predefinito del foglio di consolidamento.

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

Per applicare un formato predefinito di arial e una dimensione del carattere predefinita di 10 alla cartella di lavoro del consolidamento, prova il seguente adattamento del codice della procedura Tester:

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

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, Foglio 2"       '<<=== Modifica

    Const sFoglioDestinazione As String = _

                                        "Consolidamento"      '<<=== Modifica

    Const sFileDestinazione = _

                 "Andrea_Consolidamento.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

With destWB.Styles("Normal").Font

.Name = "Arial"

.Size = 10

.Bold = False

.Italic = False

.Underline = xlUnderlineStyleNone

.Strikethrough = False

.ThemeColor = 2

.TintAndShade = 0

.ThemeFont = xlThemeFontNone

End With    

    Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub

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

Se lo desideri, puoi anche creare un nuovo modello di foglio con il formato desiderato. a questo proposito, vedi:

Aprire automaticamente un modello di cartella di lavoro o di foglio di lavoro all'avvio di Excel

===

Regards,

Norman