Unire diversi fogli in un unico foglio

Question

Salve,

ho un file composto da diversi fogli di lavoro e ho le necessità di raggruppare i dati in un unico foglio, sempre all'interno dello stesso file.

Tutti i fogli hanno la medesima struttura, varia solo la lunghezza delle righe inserite in ogni foglio.

La struttura è la seguente:

A1: mese

riga 2 vuota

riga 3: A3 data, B3 descrizione, C3 importo

dalla riga 4 alla riga X sono inseriti i vari dati

nell'ultima riga di ciascun foglio c'è il totale

Ora io vorrei riportare in un unico foglio l'intestazione delle colonne (riga 3) e poi di seguito tutti i dati dei vari fogli (dalla riga 4 alla riga X) SENZA ripetere ogni volta l'intesta (riga 3) e SENZA riportare mai la riga finale con il totale.

Infine, in questo file ho la necessità di escludere dal riepilogo i fogli denominati "dati" e "totale".

Grazie in anticipo,

buona giornata

Answer 1

Ciao Icebrand,

la macro è quasi perfetta, l'unica cosa che manca è la somma totale delle colonne F e G, mentre attualmente viene fata solo sulla colonna C che non serve.

Sostituisci il codice precedente con:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, headerRng As Range

    Dim totRng As Range

    Dim iRow As Long, jRow As Long, kRow As Long

    Dim arrEscludere As Variant

    Dim Res As Variant

    Dim CalcMode As Long

    Const sSheetName As String = "Riepilogo"

    Const sEscludere As String = "Totale,Dati"

    Const sIndirizoIntestazioni As String = "A3:H3"

    On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set WB = ActiveWorkbook

    With WB

        On Error Resume Next

        Set destSH = .Sheets(sSheetName)

        On Error GoTo 0

        If Not destSH Is Nothing Then

            destSH.UsedRange.Offset(1).ClearContents

        Else

            Set destSH = WB.Sheets.Add(Before:=.Sheets(1))

            destSH.Name = sSheetName

        End If

    End With

    arrEscludere = Split(sEscludere, ",")

    For Each SH In WB.Sheets

        With SH

            Res = Application.Match(.Name, arrEscludere, 0)

            If IsError(Res) And SH.Name <> destSH.Name Then

                iRow = LastRow(SH)

                Set headerRng = .Range(sIndirizoIntestazioni)

                With headerRng

                    Set srcRng = .Offset(1).Resize(iRow - .Row - 1)

                End With

                jRow = LastRow(destSH)

                If jRow = 0 Then

                   headerRng.Copy Destination:=destSH.Range("A1")

                    jRow = jRow + 1

                End If

                srcRng.Copy destSH.Range("A" & jRow + 1)

            End If

        End With

    Next SH

    With destSH

        kRow = LastRow(destSH)

        Set totRng = .Range("F" & kRow + 1).Resize(1, 2)

        With totRng

            .EntireRow.Cells(2).Value = "Totale"

            .Value = "=Sum(" & "C2:C" & kRow & ")"

            .NumberFormat = "$ #,##0.00"

        End With

        With .UsedRange

            .Columns(1).NumberFormat = "dd/mm/yy"

            .EntireColumn.AutoFit

        End With

    End With

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    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

End Function

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

Potresti scaricare il mio file di prova Icebrand#3_210150405.xlsm a: **http://1drv.ms/19Ug1QL**

===

Regards,

Norman

Answer 2

Ciao Norman,

la macro è quasi perfetta, l'unica cosa che manca è la somma totale delle colonne F e G, mentre attualmente viene fata solo sulla colonna C che non serve.

Grazie ancora,

buona giornata

Answer 3

Ciao Icebrand,

ti ringrazio molto, la macro funziona benissimo.

Vorrei però chiederti 2 modifiche se possibile:

• estendere l'area dei dati riportati dalla colonna A alla colonna H (intestazione da A3 ad H3 e dati sempre dalla riga 4 alla riga X)
• inserire la riga col totale al termine dei dati riportati

Se ho capito la tua esigenza aggiornata, prova a sostituire il codice precedente con la seguente versione:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, headerRng As Range

    Dim totRng As Range

    Dim iRow As Long, jRow As Long, kRow As Long

    Dim arrEscludere As Variant

    Dim Res As Variant

    Dim CalcMode As Long

    Const sSheetName As String = "Riepilogo"

    Const sEscludere As String = "Totale,Dati"

    Const sIndirizoIntestazioni As String = "A3:H3"

    On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set WB = ActiveWorkbook

    With WB

        On Error Resume Next

        Set destSH = .Sheets(sSheetName)

        On Error GoTo 0

        If Not destSH Is Nothing Then

            destSH.UsedRange.Offset(1).ClearContents

        Else

            Set destSH = WB.Sheets.Add(Before:=.Sheets(1))

            destSH.Name = sSheetName

        End If

    End With

    arrEscludere = Split(sEscludere, ",")

    For Each SH In WB.Sheets

        With SH

            Res = Application.Match(.Name, arrEscludere, 0)

            If IsError(Res) And SH.Name <> destSH.Name Then

                iRow = LastRow(SH)

                Set headerRng = .Range(sIndirizoIntestazioni)

                With headerRng

                    Set srcRng = .Offset(1).Resize(iRow - .Row - 1)

                End With

                jRow = LastRow(destSH)

                If jRow = 0 Then

                   headerRng.Copy Destination:=destSH.Range("A1")

                    jRow = jRow + 1

                End If

                srcRng.Copy destSH.Range("A" & jRow + 1)

            End If

        End With

    Next SH

    With destSH

        kRow = LastRow(destSH)

        Set totRng = .Range("C" & kRow + 1)

        With totRng

            .EntireRow.Cells(2).Value = "Totale"

            .Value = "=Sum(" & "C2:C" & kRow & ")"

            .NumberFormat = "$ #,##0.00"

        End With

        With .UsedRange

            .Columns(1).NumberFormat = "dd/mm/yy"

            .EntireColumn.AutoFit

        End With

    End With

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    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

End Function

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

Potresti scaricare il mio file di prova aggiornato a: **http://1drv.ms/1xP9HVY**

===

Regards,

Norman

Answer 4

Cia Norman,

ti ringrazio molto, la macro funziona benissimo.

Vorrei però chiederti 2 modifiche se possibile:

• estendere l'area dei dati riportati dalla colonna A alla colonna H (intestazione da A3 ad H3 e dati sempre dalla riga 4 alla riga X)
• inserire la riga col totale al termine dei dati riportati

Grazie,

buona giornata

Answer 5

Ciao Icebrand,

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 WB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, headerRng As Range

    Dim iRow As Long, jRow As Long

    Dim arrEscludere As Variant

    Dim Res As Variant

    Dim CalcMode As Long

    Const sSheetName As String = "Riepilogo"                     

    Const sEscludere As String = "Totale,Dati"

    Const sIndirizoIntestazioni As String = "A3:C3"

    On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set WB = ActiveWorkbook

    With WB

        On Error Resume Next

        Set destSH = .Sheets(sSheetName)

        On Error GoTo 0

        If Not destSH Is Nothing Then

            destSH.UsedRange.Offset(1).ClearContents

        Else

            Set destSH = WB.Sheets.Add(Before:=.Sheets(1))

            destSH.Name = sSheetName

        End If

    End With

    arrEscludere = Split(sEscludere, ",")

    For Each SH In WB.Sheets

        With SH

            Res = Application.Match(.Name, arrEscludere, 0)

            If IsError(Res) And SH.Name <> destSH.Name Then

                iRow = LastRow(SH, .Columns("A:C"))

                Set srcRng = .Range("A4:C" & iRow - 1)

                jRow = LastRow(destSH)

                If jRow = 0 Then

                    Set headerRng = .Range(sIndirizoIntestazioni)

                    headerRng.Copy Destination:=destSH.Range("A1")

                    jRow = jRow + 1

                End If

                srcRng.Copy destSH.Range("A" & jRow + 1)

            End If

        End With

    Next SH

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    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

End Function

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

• Alt-Q per chiudere l'editor di VBA e tornare a Excel.
• Alt-F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

Potresti scaricare il mio file di prova a: **http://1drv.ms/1GsTU0E**

===

Regards,

Norman