filtrare dati su più fogli e copiare su un altro foglio con VBA

Question

Buonasera a tutti,

avrei questa esigenza che espongo:

in un file ho molti fogli ( mesi e relativi anni dal 2013 al giugno 2016  ) tutti uguali. Io dovrei filtrare su tutti i fogli, ai quali se ne aggiungeranno altri man mano che aggiorno il file, la colonna relativa alla provincia ( col J ) e copiare i dati in una nuova cartella dove ogni foglio rappresenti la provincia selezionata.  Le colonne vanno dalla A alla T.

Fare un copia/incolla richiede molto tempo perché le province sono molte e chiedevo, cortesemente, se potreste aiutarmi con un codice VBA per fare più velocemente ed in maniera esatta.

Ho trovato in un precedente thread qualcosa di simile ma era per più righe mentre i fogli erano solo due.

Ho provato qualche modifica per poterlo adattare alle mie esigenze ma niente non sono riuscito.

Mi auguro e spero di essere stato chiaro e comprensivo nella esposizione della richiesta.

Grazie e buona domenica.

Answer 1

Ciao mega, Ciao Sandro,

Ho deciso di affrontare il compito con un approccio diverso. Quindi, prova qualcosa del genere:

crea una Userform con un controllo ListBox, un controllo Label e un controllo CommandButton.

Nel modulo di codice della Userform, incolla il seguente codice:

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

Option Explicit

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

Private Sub CommandButton1_Click()

    Dim sProvincia As String

    Dim i As Long

    With Me.ListBox1

        i = .ListIndex

        sProvincia = .List(i, 1)

        Call FiltraFogli(sProvincia)

    End With

    Unload Me

End Sub

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

Private Sub UserForm_Initialize()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("Elenco Provincie")

    Set Rng = SH.Range("A1").CurrentRegion.Resize(, 4)

    With Rng

        Set Rng = .Offset(1).Resize(.Rows.Count - 1, 4)

    End With

    With Me

        With .Label1

            .Caption = "Seleziona PROVINCIA"

            .Font.Bold = True

            .ForeColor = RGB(0, 0, 256)

        End With

        With .CommandButton1

            .Caption = "Crea Workbook"

            .Font.Bold = True

            .ForeColor = RGB(0, 0, 256)

        End With

        With .ListBox1

            .ColumnCount = 4

            .RowSource = Rng.Address(external:=True)

            .ColumnHeads = True

        End With

    End With

End Sub

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

In un modulo standard, incolla il seguente codice:

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

Option Explicit

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

Public Sub FiltraFogli(sProvince As String)

    Dim srcWB As Workbook, destWB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim arrIn As Variant, arrOut() As Variant, arrHeaders As Variant

    Dim srcRng As Range, destRng As Range, rngHeaders As Range

    Dim sName As String

    Dim LRow As Long

    Dim i As Long, j As Long, k As Long

    Dim iCtr As Long, iCol As Long, jCol As Long

    Dim bHeaders As Boolean

    Dim CalcMode As Long

    Const sUltimaColonna As String = "T"                '<<=== Modifica

    Const sColonnaPrivincia As String = "J"              '<<=== Modifica

    Set srcWB = ThisWorkbook

    With srcWB.Sheets(1)

        iCol = .Columns(sColonnaPrivincia).Column

        jCol = .Columns(sUltimaColonna).Column

    End With

    For Each SH In srcWB.Worksheets

        With SH

            Set srcRng = Nothing

            If .Name <> "Elenco Provincie" Then

                LRow = LastRow(SH, .Columns(sColonnaPrivincia))

                Set srcRng = .Range("A2:" & sUltimaColonna & LRow)

                If Not bHeaders Then

                    Set rngHeaders = srcRng.Rows(0)

                    arrHeaders = rngHeaders.Value

                End If

            End If

        End With

        If Not srcRng Is Nothing Then

            arrIn = srcRng.Value

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

                If arrIn(i, iCol) = sProvince Then

                    iCtr = iCtr + 1

                    ReDim Preserve arrOut(1 To jCol, 1 To iCtr)

                    For j = 1 To jCol

                        arrOut(j, iCtr) = arrIn(i, j)

                    Next j

                End If

            Next i

        End If

    Next SH

    If iCtr Then

        Set destWB = Application.Workbooks.Add

        sName = sProvince & Format(Date, "yyyymmdd") & "xlsx"

        Set destRng = destWB.Sheets(1).Range("A2").Resize(iCtr, jCol)

        On Error GoTo XIT

        With Application

            CalcMode = .Calculation

            .Calculation = xlCalculationManual

            .ScreenUpdating = False

        End With

        With destRng

            .Value = Application.Transpose(arrOut)

            .Rows(0).Value = arrHeaders

            .EntireColumn.AutoFit

        End With

        destWB.SaveAs Filename:=sName, FileFormat:=51

        Call MsgBox( _

                 Prompt:="Sono stato trovati " & iCtr & "record per la provincia " _

                 & sProvince _

                 & vbNewLine & vbNewLine _

                 & "I datati filtrati sono stati salvati nel file " & sName, _

                 Buttons:=vbInformation, _

                 Title:="REPORT")

        Else

            Call MsgBox( _

                 Prompt:="Non sono stato trovato alcun record per la provincia " & sProvince, _

                 Buttons:=vbInformation, _

                 Title:="REPORT")

    End If

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)

    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

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

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

Per gli scopi della mia prova ho creato un file con 44 fogli mensil, da Gennaio 2013 a Agosto 2016, e ho sfruttato i dati di Sandro, modificandoli per ogni foglio con l'inserimento della data (mese & anno) del foglio di interesse nelle colonne  D:F e Q; nella colonna J dei fogli mensili, ho inserito, in modo casuale, i nomi di provincie italiane.  Ho anche inserito un primo foglio (Elenco Provincie) con una tabella delle provincie italiane e un pulsante per avviare la Userform.

Nonostante il numero di fogli e le dimensioni del file, mi pare che il codice sia molto veloce.

Potresti scaricare il mio file di prova Mega20160824.xlsm a:

https://www.dropbox.com/s/9a36kxijjbpsci5/Mega20160824.xlsm?dl=0

===

Regards,

Norman

Answer 2

Vediamo di capire bene.

Hai un tot di fogli all'interno di un file.

In questi fogli hai una colonna, la J, che contiene le provincie.

Vuoi filtrare questi fogli per provincia, copiare i dati filtrati e incollarli in un altro file dove hai fogli che corrispondono alle provincie filtrate.

Ho capito bene?

Answer 3

Buonasera Mauro,

grazie per la risposta. Ho provato a fare le modifiche che tu mi hai suggerito solo che il codice non funziona e, sinceramente, non riesco a comprendere dove sbaglio.

Dunque tu mi dici:

---

Per ciclare tutti i fogli dovresti fare una cosa del genere:

    For Each sh In ThisWorkbook.Worksheets

        If sh.Name <> "NomeDelFoglioDoveIncolli" Then

---

che io dovrei sostituire a:     ?

---

'metto un riferimento al foglio con i dati 

'(qui Foglio1)  

     Set sh = ThisWorkbook.Worksheets("Foglio1")  

---

poi:

---

  'codice di filtro e copia

---

e quindi:  ?

---

  With sh

ed a seguire fino a

            End If

        Next

    End With

---

credo di aver interpretato male ed a questo punto chiedo cortesemente il tuo aiuto per come formulare il codice esatto.

Grazie della pazienza.

Mega

Answer 4

Vediamo se riesci da solo con un piccolo aiuto.

Per ciclare tutti i fogli dovresti fare una cosa del genere:

    For Each sh In ThisWorkbook.Worksheets

        If sh.Name <> "NomeDelFoglioDoveIncolli" Then

            'codice di filtro e copia

        End If

    Next

Dove, pseudocodice:

per ogni foglio nel workbook

se il nome del foglio è diverso da quello dove andrai ad incollare

il codice del filtro e copia/incolla

Prova un po'.

Answer 5

Buonasera a tutti,

in riferimento a quanto sopra, come dicevo, ho trovato un thread con una macro che Mauro Gamberini aveva pubblicato, che riposto, che dovrebbe fare quello che io ho richiesto però su più fogli e non su uno solo ( Foglio1). Ho fatto delle modifiche ma non riesco a far eseguire il codice.

Di seguito il codice postato da Mauro Gamberini:

Public Sub m()

    'dichiaro le variabili

    Dim wk As Workbook

    Dim sh1 As Worksheet

    Dim sh As Worksheet

    Dim lUltRiga As Long

    Dim v As Variant

    Dim rng As Range

    Dim c As Range

    Dim col As Collection

    'metto un riferimento al foglio con i dati

    '(qui Foglio1)  <=========  io ho 44 fogli ai quali se ne aggiungeranno degli altri

    Set sh = ThisWorkbook.Worksheets("Foglio1")  <==== questa è la parte da modificare? giusto?

    'creo un nuovo oggetto Collection

    Set col = New Collection

    'impedisco lo sfarfallio del monitor

    Application.ScreenUpdating = False

    With sh

        'trovo l'ultima riga con i dati

        lUltRiga = .Range("E" & .Rows.Count).End(xlUp).Row

        'faccio un filtro univoco sulla colonna

        'che contiene i nomi delle città

        .Range("E1:E" & lUltRiga).AdvancedFilter _

            Action:=xlFilterInPlace, _

            Unique:=True

        'metto un riferimento alle sole celle visibili

        'del filtro fatto

        Set rng = .Range("E1:E" & lUltRiga).SpecialCells(xlCellTypeVisible)

        'popoplo la Collection con i nomi univoci delle città

        For Each c In rng

            col.Add c.Value, CStr(c.Value)

        Next

        'tolgo il filtro

        .ShowAllData

        'ciclo la Collection

        For Each v In col

            'vedo di non filtrare l'intestazione

            'della colonna E(qui Città)

            If v <> "Città" Then

                'creo un nuovo Workbook(file) e metto un

                'riferimento

                Set wk = Workbooks.Add

                'metto un riferimento al Foglio1 del nuovo file

                Set sh1 = wk.Worksheets("Foglio1")

                'filtro i dati per la città via via

                'contenuta in v

                .Range("$A$1:$J$" & lUltRiga).AutoFilter Field:=5, Criteria1:=CStr(v)

                'copio i dati filtrati del Foglio1 del file con i

                'dati nel Foglio1 del nuovo file creato

                .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _

                    Destination:=sh1.Range("A1")

                'salvo il file nella cartella C:\Prova con il nome

                'della città contenuta in v

                wk.SaveAs "C:\Prova" & v & ".xlsx"

                'chiudo il file creato

                wk.Close

                'libero la memoria

                Set wk = Nothing

            End If

        Next

    End With

    'aggiorno lo schermo

    Application.ScreenUpdating = True

    'Set a Nothing delle variabili oggetto

    Set sh = Nothing

    Set sh1 = Nothing

    Set wk = Nothing

    Set rng = Nothing

    Set c = Nothing

    Set col = Nothing

End Sub

Potrei avere un suggerimento, cortesemente, della modifica da apportare sul codice per farlo eseguire supponendo che faccia al caso mio?

Grazie e buona serata.

Mega