Copier coller ligne selon valeur colonne

Bonjour à toutes et tous,

Je souhaiterai copier/coller automatiquement des lignes de mon tableau avec la mise en forme Feuil 1 à partir de la colonne C jusqu'à la colonne K en fonction de la valeur de la colonne J >49 , dans la Feuil 2 en colonne A jusqu'à I.

Je sais qu'une macro serai la solution, mais comme vous en avez l'habitude.... de le lire, je n'y connaît rien ou presque en VBA.

Pouvez-vous m'aider dans mon projet.

Merci d'avance.

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Bonjour le fil,

Sub Copier()
Dim rng As Range
    With Sheets("Feuil1").Range("c7", Range("c" & Rows.Count).End(xlUp)).Resize(, 9)
        .AutoFilter 8, ">49"
        Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12)
        If Not rng Is Nothing Then
            rng.Copy
            Sheets("Feuil2").Range("a2").PasteSpecial
        End If
        .AutoFilter
    End With
End Sub

klin89

gmb a écrit :

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Bonjour gmb,

Il y a un petit problème, si on diminue une valeur de la colonne J pour qu'elle repasse sous la barre des 50, il reste des mises en formes sur la feuille 2.

Bonjour Klin89,

Même problème que gmb, sauf que la ligne entière reste sur la feuille 2 si dans ma feuille 1 colonne J une valeur passe sous les 50.

Re mdo100,

Comme ceci :

Option Explicit
Sub Copier()
Dim rng As Range
    With Sheets("Feuil1").Range("c7", Range("c" & Rows.Count).End(xlUp)).Resize(, 9)
        .AutoFilter 8, ">49"
        On Error Resume Next
        Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12)
        On Error GoTo 0
        If Not rng Is Nothing Then
            With Sheets("Feuil2")
                With .Range("a1").CurrentRegion
                    On Error Resume Next
                    .Offset(1).Resize(.Rows.Count - 1).Clear
                    On Error GoTo 0
                End With
                rng.Copy
                .Range("a" & Rows.Count).End(xlUp)(2).PasteSpecial
            End With
        Else
            MsgBox "Aucune donnée"
        End If
        .AutoFilter
    End With
End Sub

klin89

Re Klin89,

On y est presque, si la colonne J toutes les valeurs sont <à50 "le ou la" MsgBox indique aucune donnée, mais du coup ne supprime pas la dernière ligne dans la feuille 2.

Si je reste dans la feuille 2 et que j'active la macro, il se produit une erreur dans la macro ligne 2.

Enfin comment supprimer la désagréable sensation de clignotement du fichier lorsque la macro s'exécute.

Nouvel essai à tester.

Bye !

Merci gmb,

C'est exactement ça, c'est même parfait, vous écrivez des codes comme vous écrieriez un livre.

Je venais juste de trouver une solution à votre code en ajoutant une avant dernière ligne.

J'en était presque fier d'avoir pu rallonger votre premier code et je m'apprêtais a vous le faire savoir.

Maintenant je vais m'efforcer de comprendre le code que vous m'avez fourni sur la version "Règles v2.xlsm".

Private Sub Worksheet_Activate()

Set f1 = Sheets("Feuil1")

Range("A1").CurrentRegion.Offset(1, 0).ClearContents

For ln = 9 To f1.Range("C" & Rows.Count).End(xlUp).Row

If f1.Range("J" & ln) > 49 Then

lgn = Range("A" & Rows.Count).End(xlUp)(2).Row

f1.Range("C" & ln & ":K" & ln).Copy Range("A" & lgn)

End If

Next ln

Range("A2:A65000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Merci encore et merci à Klin89, qui m'a proposé une autre solution.

Bonne fin de soirée à vous 2.

Re mdo100,

Option Explicit
Sub Copier()
Dim rng As Range
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Sheets("Feuil1")
        .Activate
        With .Range("c7", Range("c" & Rows.Count).End(xlUp)).Resize(, 9)
            .AutoFilter 8, ">49"
            On Error Resume Next
            Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12)
            On Error GoTo 0
            With Sheets("Feuil2")
                With .Range("a1").CurrentRegion
                    On Error Resume Next
                    .Offset(1).Resize(.Rows.Count - 1).Clear
                    On Error GoTo 0
                End With
                If Not rng Is Nothing Then
                    rng.Copy
                    .Range("a" & Rows.Count).End(xlUp)(2).PasteSpecial
                Else
                    MsgBox "Aucune donnée"
                End If
            End With
            .AutoFilter
        End With
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

klin89

Bonjour Klin89,

Vous ne lâchez pas l'affaire, effectivement ça fonctionne parfaitement cette fois-ci.

Je vais également étudier votre code qui pourra me servir et là je pense a un autre fichier auquel j'adapterai votre code avec un bouton.

Je vous remercie de l'aide que vous m'avez apporté et vous souhaite un bon dimanche.