Copiare range di celle da Foglio1 a Foglio2 con una formula SE una condizione è vera

Question

Ciao a tutti,

ho un file .xlsx con Foglio1 e Foglio2.

In Foglio1 ho una serie di colonne da A ad E con dati di vario genere, e prima riga con intestazioni.

Se il contenuto della cella E2 è "Presente", allora le celle A2, B2, D2, E2 devono essere copiate in Foglio2 nella prima riga vuota dopo l'intestazione, ed eventualmente sotto altre celle già copiate allo stesso modo.

Come posso fare?

Grazie

Diego

Answer 1

In A2 del Foglio2

=SE(Foglio1!$E2>0;Foglio1!A2;"")

formula da trascinare a destra fino in E2 e poi tutta la fila A2:E2 in basso.

Answer 2

Ciao Diego,

ho un file .xlsx con Foglio1 e Foglio2.

In Foglio1 ho una serie di colonne da A ad E con dati di vario genere, e prima riga con intestazioni.

Se il contenuto della cella E2 è "Presente", allora le celle A2, B2, D2, E2 devono essere copiate in Foglio2 nella prima riga vuota dopo l'intestazione, ed eventualmente sotto altre celle già copiate allo stesso modo.

Come posso fare?

Prova qualcosa del genere:

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

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

Option Explicit

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

Private Sub Worksheet_Activate()

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim Rng As Range, rCell As Range

    Dim copyRng As Range, copyRng2 As Range

    Dim headerRng As Range

    Dim LRow As Long, LCol As Long

    Const iPrimaRigaDati As Long = 3

    Const miaColonna As String = "E"

    Const sFoglioFonte As String = "Foglio1"

    Const sMioValore As String = "Presente"

    Const sColonneDiInteresse As String = "A:E"

   On Error GoTo ErrHandler

    Set srcSH = ThisWorkbook.Sheets(sFoglioFonte)

    With srcSH

        LRow = LastRow(srcSH, .Columns(miaColonna))

        LCol = .Columns(sColonneDiInteresse).Columns.Count

        Set Rng = .Cells(iPrimaRigaDati, miaColonna).Resize(LRow)

        Set headerRng = .Range("A1").Resize(iPrimaRigaDati - 1, LCol)

        On Error Resume Next

        Set srcRng = Rng.SpecialCells(xlCellTypeConstants)

        On Error GoTo ErrHandler

        If Not srcRng Is Nothing Then

            For Each rCell In srcRng.Cells

                With rCell

                    If UCase(.Value) = UCase(sMioValore) Then

                        If copyRng Is Nothing Then

                            Set copyRng = rCell

                        Else

                            Set copyRng = Union(rCell, copyRng)

                        End If

                    End If

                End With

            Next rCell

        End If

        With Application

            .Calculation = xlCalculationManual

            .ScreenUpdating = False

            .EnableEvents = False

        End With

        With Me

            .UsedRange.Clear

            If Not copyRng Is Nothing Then

                Set destRng = .Range("A1")

                With destRng

                    Set copyRng2 = Intersect(copyRng.EntireRow, _

                                             srcSH.Range(sColonneDiInteresse))

                    copyRng2.Copy Destination:=.Offset(2)

                    headerRng.Copy

                    .PasteSpecial Paste:=xlPasteAll, _

                                  Operation:=xlNone, _

                                  SkipBlanks:=False, _

                                  Transpose:=False

                    .PasteSpecial Paste:=xlPasteColumnWidths

                End With

            End If

        End With

    End With

XIT:

    With Application

        .Calculation = xlCalculationAutomatic

        .ScreenUpdating = True

        .EnableEvents = True

    End With

   On Error GoTo 0

   Exit Sub

ErrHandler:

    Call MsgBox( _

           Prompt:="Errore " & Err.Number _

            & " (" & Err.Description & ") nella routine Worksheet_Activate", _

           Buttons:=vbCritical, _

           Title:="ERRORE")

           Resume XIT

End Sub

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

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

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

Option Explicit

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

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

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

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

Ora, ogni volta che si seleziona il Foglio2, i suoi dati saranno automaticamente aggiornati.

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

https://www.dropbox.com/s/6rx81648zfl8rr5/Diego20160122.xlsm?dl=0

===

Regards,

Norman