Macro sposta riga da un foglio ad un altro

Question

Salve, avrei bisogno di una macro per spostare una riga( Costituita da colonne A:Z) da un foglio"AZIENDE ATTIVE" ad un altro"AZIENDE DISMESSE" nel momento in cui nella prima colonna"STATO viene selezionato "DISMESSA".

Avrei bisogno che nel Foglio "AZIENDE ATTIVE" venisse contestualmente eliminata la riga spostata nel foglio "AZIENDE DISMESSE".

Inoltre dovrebbe essere possibile invertire il processo( dal foglio "AZIENDE DISMESSE" al foglio"AZIENDE ATTIVE")  nel momento in cui viene selezionato"ATTIVA".

Grazie in anticipo

Answer 1

Ciao MAr585,

Questo è il link di we transfer: https://we.tl/t-fvpfdYSo7L

Grazie in anticipo

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

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

Option Explicit

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

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim destSH As Worksheet

    Dim rng As Range, rCell As Range

    Dim destRng As Range

    Dim LRow As Long

    Const sParola_Chiave As String = "DISMESSA"                  '<<=== Modifica

    Const sFoglio_Destinazione As String = "DISMESSE"        '<<=== Modifica

    Set rng = Intersect(Me.Columns(1), Target)

    If Not rng Is Nothing Then

        Set destSH = ThisWorkbook.Sheets(sFoglio_Destinazione)

        With destSH

            LRow = LastRow(destSH, .Columns("A:A"))

            Set destRng = .Range("A" & LRow + 1).Resize(1, 26)

        End With

        For Each rCell In rng.Cells

            With rCell

                If .Value = sParola_Chiave Then

                  On Error GoTo XIT

                  Application.EnableEvents = False

                    .Resize(1, 26).Cut

                     Application.Goto destRng

                    ActiveSheet.Paste

                End If

            End With

        Next rCell

    End If

XIT:

Application.EnableEvents = True

End Sub

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

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Fai clic dx sulla linguetta del foglio DISMESSE
• Seleziona l'opzione Visualizza Codicedal****menu contestuale risultante
• Incolla il seguente codice:

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

Option Explicit

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

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim destSH As Worksheet

    Dim rng As Range, rCell As Range

    Dim destRng As Range

    Dim LRow As Long

    Const sParola_Chiave As String = "ATTIVA"                 '<<=== Modifica

    Const sFoglio_Destinazione As String = "ATTIVE"       '<<=== Modifica

    Set rng = Intersect(Me.Columns(1), Target)

    If Not rng Is Nothing Then

        Set destSH = ThisWorkbook.Sheets(sFoglio_Destinazione)

        With destSH

            LRow = LastRow(destSH, .Columns("A:A"))

            Set destRng = .Range("A" & LRow + 1).Resize(1, 26)

        End With

        For Each rCell In rng.Cells

            With rCell

                If .Value = sParola_Chiave Then

                  On Error GoTo XIT

                  Application.EnableEvents = False

                    .Resize(1, 26).Cut

                     Application.Goto destRng

                    ActiveSheet.Paste

                End If

            End With

        Next rCell

    End If

XIT:

Application.EnableEvents = True

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

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If rng Is Nothing Then

            Set rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            Application.ScreenUpdating = False

            .Unprotect Password:=sPassword

        End If

    End With

    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

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

    Application.ScreenUpdating = True

End Function

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

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

Potresti scaricare il mio file di prova MAr20190625.xlsm

===

Regards,

Norman

Answer 2

Ciao MAr585,

Grazie sei stato gentilissimo

Prego! :-)

Alla prossima.

===

Regards,

Norman

Answer 3

Grazie sei stato gentilissimo

Answer 4

Questo è il link di we transfer: https://we.tl/t-fvpfdYSo7L

Grazie in anticipo

Answer 5

Ciao MAr585,

Salve, avrei bisogno di una macro per spostare una riga( Costituita da colonne A:Z) da un foglio"AZIENDE ATTIVE" ad un altro"AZIENDE DISMESSE" nel momento in cui nella prima colonna"STATO viene selezionato "DISMESSA".

Avrei bisogno che nel Foglio "AZIENDE ATTIVE" venisse contestualmente eliminata la riga spostata nel foglio "AZIENDE DISMESSE".

Inoltre dovrebbe essere possibile invertire il processo( dal foglio "AZIENDE DISMESSE" al foglio"AZIENDE ATTIVE")  nel momento in cui viene selezionato"ATTIVA".

Per evitare che sia necessario recreare il tuo file, ti chiederei gentilmente di caricare un esempio del file , dopo averlo depurato dei dati sensibili, su un servizio di condivisione di file, ad esempio Microsoft OneDrive o DropBox, e postare un link al file in una risposta qui.

Per caricare il file su  DropBox, vedi:

Come faccio a condividere file e cartelle in Dropbox? 

===

Regards,

Norman