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

Ciao Andrea,

Perfetto Norman, ho rimesso in ordine la procedura Tester con tutte le varie modifiche precedenti. Ora funziona egregiamente!

Grazie, ancora per la pazienza.

Bene! Mi fa piacere.

Per chiudere questo thread, vorrei chiederti gentilmente di controllare l'opzione Contrassegna come risposta dal menu a discesa - Strumenti avanzati, sotto la rispettiva risposta.

In questo modo, le risposte convalidate saranno promosse immediatamente al di sotto della domanda iniziale, e tutti gli altri lettori che hanno la stessa preoccupazione , saranno in grado di trovare più facilmente la risposta, durante la loro ricerca nel nostro forum e su internet.

===

Regards,

Norman

Answer 3

Perfetto Norman, ho rimesso in ordine la procedura Tester con tutte le varie modifiche precedenti. Ora funziona egregiamente!

Grazie, ancora per la pazienza.

La riporto completa:

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

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

                                           "Consolidazione"     '<<=== Modifica

    Const sFileDestinazione = _

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

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

    Const sPercoso_Salvataggio As String = _

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

        End With

        Call MsgBox( _

         Prompt:="Finito", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub