Microsoft 365 Perfectionner une Macro

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Wisefun77

XLDnaute Nouveau
Bonjour,
Cette macro fonctionne bien.

Code:
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.

VB:
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.
 
Solution
Bonjour,
Essaie :
VB:
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
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Question Question
Microsoft 365 worksheet_change
Réponses
29
Affichages
247
Réponses
7
Affichages
88
Réponses
2
Affichages
299
Réponses
4
Affichages
143
Retour