Microsoft 365 Perfectionner une Macro

[Wisefun77]

Bonjour,
Cette macro fonctionne bien.

Sub todocopy()
Worksheets("Suivi").UsedRange.Copy
 Worksheets("TODO").Paste _
 Worksheets("TODO").Range("A1")
 Application.CutCopyMode = False
  Debut = 3
 Fin = 990
 ColNb = 1
For i = Debut To Fin
If Cells(i, ColNb).Value = "TO DO" Then
Cells(i, ColNb).EntireRow.Hidden = False
Else
Cells(i, ColNb).EntireRow.Hidden = True
End If
Next i
Worksheets("TODO").Activate
End Sub

Je me demande si je ne pourrai pas l'améliorer.

En fait il faudrait que je dise :

Si dans la colonne A depuis la ligne 2 à la ligne 1000 , il y a dans une cellule le mot "OK"

Alors copier toutes les lignes dans la feuille "OK" à partir de la ligne 2.

J'ai essayé mais je vois pas comment lui donner le mot à rechercher.

Ce code fait afficher de suite la MsgBox, et tourne en boucle, je dois arrêter le processus Excel via le gestionnaire des tâches.

Sub okcopy2()
 Debut = 2
 Fin = 990
 ColNb = 1
For i = Debut To Fin
If Cells(i, ColNb).Value = "OK" Then
Worksheets("Suivi").UsedRange.Copy
 Worksheets("OK").Paste _
 Worksheets("OK").Range("A1")
 Application.CutCopyMode = False
Else
MsgBox "Pas d'incident de fermé"
End If
Next i
Worksheets("OK").Activate
End Sub

Merci à vous.

 

[vgendron]

Bonjour

tu souhaites copier ou affficher les lignes ?
avec un fichier exemple, on pourra t'aider.

 

[Deadpool_CC]

Si dans la colonne A depuis la ligne 2 à la ligne 1000 , il y a dans une cellule le mot "OK"

Alors copier toutes les lignes dans la feuille "OK" à partir de la ligne 2.

Si un Ok (ou plus) dans la colonne A alors on copie les 1000 lignes dans l'autre onglet ... j'ai bien compris ?

 

[Wisefun77]

Bonjour Deadpool_CC,
Oui c'est bien cela.
Voici le fichier.
Merci beaucoup.

 

[danielco]

Bonjour Deadpool_CC,
Oui c'est bien cela.
Voici le fichier.
Merci beaucoup.

Bonjour,

Essaie :

Sub test()
  With Sheets("Suivi")
    If IsNumeric(Application.Match("OK", .[A:A], 0)) Then
      .[2:1000].EntireRow.Copy Sheets("OK").[A2]
    End If
  End With
End Sub

Daniel

 

[Deadpool_CC]

@danielco m'a devancé ...
bon et bien je vais pourvoir déco. ...lol

 

[Wisefun77]

Bonjour Danielco,

Je viens de tester ton code et cela copie toutes les lignes y compris celle que ne contiennent pas "OK".
Pas trop grave pour le moment.
Merci pour vos aides.

 

[Deadpool_CC]

Je viens de tester ton code et cela copie toutes les lignes y compris celle que ne contiennent pas "OK".

cela m'étonnait aussi c'est pour cela que je t'avais demandé confirmation dans le post #3 et tu as bien valider qu'il fallait qu'on copie toutes les lignes si au moins 1 "Ok" ...

 

[Wisefun77]

Bonjour Deadpool_CC,
Désolé, je le suis encore mal exprimé.
J'aimerai que seulement les lignes comportant "OK" soient copiée.
Pardonnez mon erreur, la vieillesse étant.
Merci beaucoup.

 

[TooFatBoy]

Bonjour,

Une proposition :

Sub CopierLignesOK()
'
    Application.ScreenUpdating = False

    ' Suppression de toutes les lignes de données du tableau "Tableau312" s'il n'est pas vide
    With Range("Tableau312")
        If Not .ListObject.DataBodyRange Is Nothing Then .Delete
    End With

    ' Désactivation du filtrage du tableau de la feuille "Suivi"
    Sheets("Suivi").ListObjects("Tableau3").Range.AutoFilter

    ' Filtrage des lignes dont la cellule de la première colonne est égale à "OK"
    Sheets("Suivi").ListObjects("Tableau3").Range.AutoFilter Field:=1, Criteria1:="OK"

    ' Copie des lignes filtrées du tableau
    Sheets("Suivi").ListObjects("Tableau3").DataBodyRange.Copy

    ' Collage des lignes copiées
    Range("Tableau312")(1).PasteSpecial Paste:=xlPasteValues

    ' Désactivation du filtrage du tableau de la feuille "Suivi"
    Sheets("Suivi").ListObjects("Tableau3").Range.AutoFilter Field:=1

    Application.ScreenUpdating = True

End Sub

 

[danielco]

Bonjour,
Essaie :

Sub test()
  Dim Plage As Range
  With Sheets("Suivi")
    .ListObjects(1).Range.AutoFilter 1, "ok"
    Set Plage = .ListObjects(1).AutoFilter.Range
    If Application.Subtotal(103, Plage.Resize(, 1)) > 1 Then
      Plage.Offset(1).Resize(Plage.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy [OK!A2]
      .ListObjects(1).Range.AutoFilter
    End If
  End With
End Sub

 

[TooFatBoy]

Ce code fait afficher de suite la MsgBox, et tourne en boucle, je dois arrêter le processus Excel via le gestionnaire des tâches.

Ou peut-être plus simplement par <Ctrl><Break>.

 

[Wisefun77]

Bonjour danielco, TooFatBoy,
Merci pour vos code.
J'ai testé celui de danielco, c'est super.
J'ai testé celui de TooFatBoy, c'est super.
Mais je ne sais pas pourquoi je le sens plus à l' aise avec le code de danielco.
Je vais étudier plus fond celui de TooFatBoy,
Et merci aussi pour l'astuce.

Ce code fait afficher de suite la MsgBox, et tourne en boucle, je dois arrêter le processus Excel via le gestionnaire des tâches.

Ou peut-être plus simplement par <Ctrl><Break>.

Merci de tout cœur.

 

[TooFatBoy]

Mais je ne sais pas pourquoi je me sens plus à l'aise avec le code de danielco.

J'ai l'habitude... apparemment c'est normal, ça le fait à tout le monde !...
😭 C'est vraiment trop inzuste ! 😭




😅😂🤣

 

[danielco]

J'ai l'habitude... apparemment c'est normal, ça le fait à tout le monde !...
😭 C'est vraiment trop inzuste ! 😭

Bonjour @TooFatBoy
J'ai pourtant trouvé ton code plus complet que le mien, et plus simple, aussi. Et commenté, en plus !