XL 2021 Copier une plage de données d'après un critère en VBA

exit sub

Sub Transfert()
Dim nf$, FDest As Worksheet, lig&, col%
nf = ActiveSheet.Name
Set FDest = Sheets(Switch(nf = "Matin", "Soir", nf = "Soir", "Nuit", nf = "Nuit", "Matin"))
Application.ScreenUpdating = False
For lig = 64 To 70 Step 2
    If Cells(lig, "F") = "Actif" Then
        For col = 1 To 22
            If col = Cells(lig, col).MergeArea.Column Then
                FDest.Cells(lig, col) = Cells(lig, col).Value2 'copie la valeur
                Cells(lig, col) = "" 'effacement si c'est nécessaire
            End If
        Next col
    Else
        FDest.Rows(lig) = "" 'effacement si c'est nécessaire
    End If
Next lig
FDest.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto FDest.[B50], True 'cadrage
ActiveWindow.SmallScroll ToRight:=-1
End Sub

Sub Transfert()
Dim nf$, FDest As Worksheet, ligvide&, lig&, col%
nf = ActiveSheet.Name
Set FDest = Sheets(Switch(nf = "Matin", "Soir", nf = "Soir", "Nuit", nf = "Nuit", "Matin"))
Regroupe FDest, ligvide 'regroupe la zone de destination
Application.ScreenUpdating = False
For lig = 64 To 70 Step 2
    If Cells(lig, "F") = "Actif" Then
        If ligvide > 70 Then MsgBox "Il n'y a plus de ligne vide en zone de destination !", 48: Exit For
        For col = 2 To 22
            FDest.Cells(ligvide, col) = Cells(lig, col).Value2 'copie la valeur
        Next col
        Rows(lig) = "" 'efface la ligne source
        ligvide = ligvide + 2
    End If
Next lig
Regroupe ActiveSheet 'regroupe la zone source
End Sub

Sub Regroupe(F As Worksheet, Optional ligvide&)
Dim lig&, col%
ligvide = 64
For lig = 64 To 70 Step 2
    If Application.CountA(F.Cells(lig, 2).Resize(, 21)) Then 'si la ligne n'est pas vide
        For col = 2 To 22
            F.Cells(ligvide, col) = F.Cells(lig, col).Value2 'copie la valeur
        Next col
        If lig > ligvide Then F.Rows(lig) = "" 'efface la ligne
        ligvide = ligvide + 2
    End If
Next lig
End Sub