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

[fenec]

Bonjour le forum,
Besoin de votre aide pour pouvoir copier une plage de données dans une autre feuille si une celle contient l'argument "Actif".
je vous joint un fichier avec le code que j'ai trouvé mais qui ne tient compte de l'argument et qui me recopier les lignes déjà copier.

En espérant avoir été clair,
D'avance merci

 

[sylvanu]

Bonjour Fenec,
On copie de quelle feuille vers quelle feuille ?
Comment différencier Matin/Soir/Nuit dans votre tableau ?

 

[fenec]

Bonjour Sylvanu,
On copier de la feuille: matin vers soir quand on est du matin
soir vers nuit quand on est du soir
et de nuit vers matin quand on est de nuit
la sélection de le feuille se faisant via un userforum

 

[fenec]

Re,
Une autre précision, si les cellules ne contiennent pas l'argument "Actif" alors

exit sub

 

[sylvanu]

Re,
Un essai en PJ.
J'ai supprimé toutes les cellules fusionnées car c'est une plaie à gérer.

 

[Phil69970]

Bonjour à tous
Edit Sylvain j'ai pas copié mais j'ai aussi supprimé toutes les cellules fusionnées 🤣

Je te propose ce fichier

Les lignes fusionnées c'est pas une bonne idée !!!!!

Merci de ton retour

 

[fenec]

Bonjour le Forum, Sylvanu, Phil69970,
Tout d'abord merci à vous de vous penchez sur ma problèmatique.
Mais j'aurais du vous donner un fichier exacte en présentation cela vous aurez empécher de vous faire perdre un temps précieux.
Je peux éventuellement supprimer les lignes fusionnées mais en aucun cas les colonnes.
Vous joint un fichier de ma struture.

 

[oguruma]

Re,
Un essai en PJ.
J'ai supprimé toutes les cellules fusionnées car c'est une plaie à gérer.

Ohhhhhhhhhhhh que OUI pour m'y être frotté 🙁

 

[sylvanu]

Bonjour,
@fenec,
Dans votre fichier il n'y a que 4 lignes à transférer ( de 64 à 71 avec les fusionnées ), peut il y en avoir plus ?
Dans ce cas il faudra aussi insérer des lignes dans la feuille de destination ?

 

[fenec]

Bonjour Sylvanu,

Non il n'y aura jamais plus de 4 lignes de rempli par poste la structure de changeras plus.

 

[sylvanu]

Re,
Voir PJ. Tous les formats sont conservés.
Le transfert d'une feuille à une autre se fait par appui sur le bouton Transfert.

 

[job75]

Bonsoir à tous,

J'ai toujours été surpris par cette phobie des cellules fusionnées.

Alors que la plupart du temps il y a moyen de s'en accommoder.

C'est même très simple ici :

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

A+

 

[fenec]

Bonjour le forum, sylvanu, job75

@sylvanu

Ton code correspond complétement à mon attente avec la cerise sur le gâteau qui est de regrouper les lignes sans lignes vides.
Un grand merci à toi,

@job75

Ton code fonctionne également très bien mais est un peu plus le mal à le comprendre. Dommage qu'il ne fasse pas comme celui de sylanu pour le regroupement des lignes.
Néanmoins merci pour ton aide également,

Cordialement,

Fenec.

 

[job75]

Bonjour fenec, le forum,

@job75

Dommage qu'il ne fasse pas comme celui de sylanu pour le regroupement des lignes.

Oui en effet avec le regroupement c'est beaucoup mieux.

Alors voyez le code suivant qui je pense traite tous les cas de figure :

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

La macro Regroupe est une macro paramétrée.

A+

 

[fenec]

Bonjour le forum, job75,

Un grand merci à toi, ton code fonctionne super bien.

Une petite question si tu permet:

Avant on pouvait modifier le titre de la demande en marquant "résoulu" mais je ne sais plus faire la manipulation, pourrais-tu m'éclairer sur ce point.

D'avance merci.

A+