Deplacer le contenu des ligne cocher puis remonter les vivantes

Bonsoir,

Je veux lancer une macro en cliquant sur le bouton realiser qui aura comme effet de déplacer le contenu des cellules B et C dont les case à cocher son cochée "cellule en vert" vers la feuil2, puis de remonter le contenu des cellules qui ne sont pas coché. Il ne faut pas supprimer les cellules avec les bordures en gras doivent rester même vide.

Merci

Bonsoir,

Je ne comprends pas ce que veux dire ne pas couper les lignes, et je ne voix pas d'étiquettes !

Bonsoir,

Couper = ne pas supprimer des lignes

Étiquette = les cellules qui ont les bordure en gras

Merci

OK !

Sub Tchouss()
    Dim RQVrai(), RQFaux(), v%, f%, n%, i%
    With ActiveSheet
        Application.ScreenUpdating = False
        n = .Cells(.Rows.Count, 2).End(xlUp).Row
        ReDim RQFaux(n - 4, 1)
        For i = 4 To n Step 2
            If .Cells(i, 5) = True Then
                ReDim Preserve RQVrai(1, v)
                RQVrai(0, v) = .Cells(i, 2): RQVrai(1, v) = .Cells(i, 3)
                .Cells(i, 5) = False: v = v + 1
            ElseIf .Cells(i, 5) = False Then
                RQFaux(f, 0) = .Cells(i, 2): RQFaux(f, 1) = .Cells(i, 3)
                f = f + 2
            End If
        Next i
        .Range("B4:C" & n).Value = RQFaux
    End With
    Worksheets("Feuil2").Range("A2").Resize(v, 2).Value = WorksheetFunction.Transpose(RQVrai)
End Sub

Cordialement.

Merci pour la qualité et la rapidité de la réponse, mais tout ne se déplace pas dans la feuil2.

Si je coche une par une et je lance la macro a chaque fois cela apparait pas dans la feuil2.

Ce que j'ai omis, c'est la répétition de l'opération, elle efface les précédentes... !

Il faut modifier la fin ainsi :

    With Worksheets("Feuil2")
        f = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Range("A" & f).Resize(v, 2).Value = WorksheetFunction.Transpose(RQVrai)
    End With
End Sub

Mille merci parfait

Peux-tu me dire comment rendre cette marco automatique, tout les 30 minutes.

Il faut la faire se relancer toutes les 30 minutes, mais il te faut une conditions d'arrêt, sinon ça ne s'arrêtera pas...

Sans rien ajouter, on peut faire ainsi sur la fin de la macro :

    If v > 0 Then
        Application.OnTime Now + TimeValue("00:30:00"), "Tchouss"
    Else
        Exit Sub
    End If
    With Worksheets("Feuil2")
        f = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Range("A" & f).Resize(v, 2).Value = WorksheetFunction.Transpose(RQVrai)
    End With
End Sub

Si v est supérieur à 0, c'est qu'elle a trouvé des vrais, à ce moment là elle reprogramme son lancement pour une demi-heure plus tard. si v=0, pas de vrais, elle interrompt la programmation. Et dans ce cas il ne faut pas qu'elle exécute l'intervention sur Feuil2 qui provoquerait une erreur en l'absence de tableau de vrais, donc elle sort.

Cordialement.

Merci parfait.

Bonsoir,

il faudrait rajouter la fonction si rien est coché, je ne fais rien.

Merci

Bonjour,

Désolé pour le délai, j'étais absent du Forum depuis mi-février...

Il m'apparaît que si rien n'est coché, il n'y a pas de Vrai, donc v sera =0, et dans ce cas la procédure s'arrête et ne reporte rien sur la feuille 2.

Sur la feuille 1 elle reproduit la situation existante avec cette ligne :

        .Range("B4:C" & n).Value = RQFaux

On peut éviter d'exécuter cette ligne, inutile si rien de coché, en la déplaçant dans la condition qui suit, ou mieux dans la pratique, en déplaçant la condition dans le bloc With pour y insérer cette ligne sans avoir à la modifier...

Sub Tchouss()
    Dim RQVrai(), RQFaux(), v%, f%, n%, i%
    With ActiveSheet
        Application.ScreenUpdating = False
        n = .Cells(.Rows.Count, 2).End(xlUp).Row
        ReDim RQFaux(n - 4, 1)
        For i = 4 To n Step 2
            If .Cells(i, 5) = True Then
                ReDim Preserve RQVrai(1, v)
                RQVrai(0, v) = .Cells(i, 2): RQVrai(1, v) = .Cells(i, 3)
                .Cells(i, 5) = False: v = v + 1
            ElseIf .Cells(i, 5) = False Then
                RQFaux(f, 0) = .Cells(i, 2): RQFaux(f, 1) = .Cells(i, 3)
                f = f + 2
            End If
        Next i
        If v > 0 Then
            .Range("B4:C" & n).Value = RQFaux
            Application.OnTime Now + TimeValue("00:30:00"), "Tchouss"
        Else
            Exit Sub
        End If
    End With
    With Worksheets("Feuil2")
        f = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Range("A" & f).Resize(v, 2).Value = WorksheetFunction.Transpose(RQVrai)
    End With
End Sub

Cordialement.