Copiare righe da vari fogli excel a un determinato foglio

Question

Buon pomeriggio a tutt*,

ho cercato e ricercato soluzioni simili ma non ne vengo a capo.

Vi porgo il mio problema.

Ho un file excel con fogli di lavoro ognuno per ogni mese e altri fogli di lavoro, nei fogli di lavoro mensili ho una tabella e vorrei che per ogni foglio vengano copiate le righe in un nuovo foglio se una colonna delle varie tabelle (che sono tutte uguali) ha No all'interno. Oltre a questo nel nuovo foglio non servono tutte le colonne della tabella, ma solo alcune di queste. Inoltre, sarebbe utile ordinarle per data di scadenza e quando l'opzione passa da No a Si, si tolga l'intera riga.

Siccome è un po complicato spiegare metto il link di un file con dati fittizi e molto semplificata.

Vorrei che nel foglio Card18 vengano copiate solo le colonne riportate, che si trovano nelle tabelle Gen18, Feb18, Mar18.

Spero di essere stata chiara ma ne dubito :)

Grazie comunque per le eventuali risposte.

https://www.dropbox.com/s/g1zpgkoiio77qls/esempio.xlsx?dl=0

Answer 1

Ciao Eva,

Chiedo scusa perché ritorno tardivavamente alla tua domanda!

Prova a sostituire il codice precedente con la seguente versione:

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

Option Explicit

Option Compare Text

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

Public Sub Aggiorna_Card(aSH As Worksheet)

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim srcSH As Worksheet

    Dim srcRng As Range, deatRng As Range

    Dim LObj As ListObject

    Dim arrIn As Variant, arrOut() As Variant

    Dim arrColonne As Variant

    Dim Res As Variant

    Dim vVal As Variant

    Dim arrMese As Variant

    Dim aStr As String, bStr As String

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

    Dim iCtr As Long, jCtr As Long, iCol As Long

    Dim bFlag As Boolean

    Const sColonne_Da_Copiare As String = _

                                             "1,2,4,6,7,8,9,10"       '<<=== Modifica

    Const iColonna_Attivata As Long = 13               '<<=== Modifica

    Const sPrefisso As String = "Card_"                     '<<=== Modifica

    Set WB = ThisWorkbook

    arrMese = Application.GetCustomListContents(3)

    arrColonne = Split(sColonne_Da_Copiare, ",")

    For Each SH In WB.Worksheets

        With SH

            aStr = .Name

            bStr = Left(aStr, 3)

            Res = Application.Match(bStr, arrMese, 0)

            If Not IsError(Res) Then

                Set srcRng = .ListObjects(sPrefisso & aStr).DataBodyRange

                arrIn = srcRng.Value2

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

                    If arrIn(i, iColonna_Attivata) = "NO" Then

                        iCtr = iCtr + 1

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

                        For j = LBound(arrColonne) To UBound(arrColonne)

                            jCtr = jCtr + 1

                            iCol = arrColonne(jCtr - 1)

                            vVal = arrIn(i, iCol)

                            arrOut(jCtr, iCtr) = vVal

                        Next j

                        jCtr = 0

                    End If

                Next i

            End If

        End With

    Next SH

    bFlag = CBool(iCtr)

    If bFlag Then

        arrOut = Application.Transpose(arrOut)

    End If

    With aSH.ListObjects(1)

        If Not .DataBodyRange Is Nothing Then

            .DataBodyRange.Delete

        End If

        If bFlag Then

            .HeaderRowRange.Offset(1). _

                    Resize(UBound(arrOut)).Value2 = arrOut

            .Range.Sort key1:=.ListColumns(4), _

                        order1:=xlAscending, _

                        Header:=xlYes, _

                        OrderCustom:=1, _

                        MatchCase:=False, _

                        Orientation:=xlTopToBottom

        End If

    End With

End Sub

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

===

Regards,

Norman

Answer 2

Ciao evoich8,

ho cercato e ricercato soluzioni simili ma non ne vengo a capo.

Vi porgo il mio problema.

Ho un file excel con fogli di lavoro ognuno per ogni mese e altri fogli di lavoro, nei fogli di lavoro mensili ho una tabella e vorrei che per ogni foglio vengano copiate le righe in un nuovo foglio se una colonna delle varie tabelle (che sono tutte uguali) ha No all'interno. Oltre a questo nel nuovo foglio non servono tutte le colonne della tabella, ma solo alcune di queste. Inoltre, sarebbe utile ordinarle per data di scadenza e quando l'opzione passa da No a Si, si tolga l'intera riga.

Siccome è un po complicato spiegare metto il link di un file con dati fittizi e molto semplificata.

Vorrei che nel foglio Card18 vengano copiate solo le colonne riportate, che si trovano nelle tabelle Gen18, Feb18, Mar18.

Spero di essere stata chiara ma ne dubito :)

Grazie comunque per le eventuali risposte.

https://www.dropbox.com/s/g1zpgkoiio77qls/esempio.xlsx?dl=0

Prova qualcosa del genere:

• Fai clic dx sulla linguetta del foglio Card18
• Seleziona l'opzione Visualizza Codice dal menu contestuale risultante
• Incolla il seguente codice:

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

Option Explicit

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

Private Sub Worksheet_Activate()

    Call Aggiorna_Card(Me)

End Sub

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

• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

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

Option Explicit

Option Compare Text

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

Public Sub Aggiorna_Card(aSH As Worksheet)

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim srcSH As Worksheet

    Dim srcRng As Range, deatRng As Range

    Dim LObj As ListObject

    Dim arrIn As Variant, arrOut() As Variant

    Dim arrColonne As Variant

    Dim Res As Variant

    Dim arrMese As Variant

    Dim aStr As String, bStr As String

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

    Dim iCtr As Long, jCtr As Long, iCol As Long

    Const sPrefix As String = "Card"

    Const sColonne_Da_Copiare As String = "1,2,4,5,7,9"

    Set WB = ThisWorkbook

    arrMese = Application.GetCustomListContents(3)

    arrColonne = Split(sColonne_Da_Copiare, ",")

    For Each SH In WB.Worksheets

        With SH

            aStr = .Name

            bStr = Left(aStr, 3)

            Res = Application.Match(bStr, arrMese, 0)

            If Not IsError(Res) Then

                Set srcRng = .ListObjects(1).DataBodyRange

                arrIn = srcRng.Value

                '                jCtr = 0

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

                    If arrIn(i, 9) = "NO" Then

                        iCtr = iCtr + 1

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

                        For j = LBound(arrColonne) To UBound(arrColonne)

                            jCtr = jCtr + 1

                            iCol = arrColonne(jCtr - 1)

                            If iCol = 3 Or iCol = 4 Then

                                arrOut(jCtr, iCtr) = CLng(arrIn(i, iCol))

                            Else

                                arrOut(jCtr, iCtr) = arrIn(i, iCol)

                            End If

                        Next j

                        jCtr = 0

                    End If

                Next i

            End If

        End With

    Next SH

    arrOut = Application.Transpose(arrOut)

    With aSH.ListObjects(1)

        If Not .DataBodyRange Is Nothing Then

            .DataBodyRange.Delete

        End If

        .HeaderRowRange.Offset(1). _

                Resize(UBound(arrOut)).Value2 = arrOut

        .Range.Sort key1:=.ListColumns(4), _

                    order1:=xlAscending, _

                    Header:=xlYes, _

                    OrderCustom:=1, _

                    MatchCase:=False, _

                    Orientation:=xlTopToBottom

    End With

End Sub

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

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm

Ogni volta che il foglio Card18 venga selezionato, i dai nella sua tabella verranno automaticamente aggiornati.

Potresti scaricare il mio file di prova Evoich20180806.xlsm

===

Regards,

Norman

Answer 3

Ciao Eva,

scusa per il ritardo nella risposta, ho sostituito  il codice e funziona come volevo. Grazie!!!

Ma fa piacere!

Mi studierò un po' il codice per capire meglio il ragionamento, o almeno ci provo.

Bene! Siamo sempre qui casomai ti servisse qualche chiarimento!

===

Regards,

Norman

Answer 4

Ciao,

scusa per il ritardo nella risposta, ho sostituito  il codice e funziona come volevo. Grazie!!!

Mi studierò un po' il codice per capire meglio il ragionamento, o almeno ci provo.

Grazie ancora, Eva