XL 2016 macro toute bête qui tourne en boucle

douguy

XLDnaute Junior
bonjour et belle année 2019 à tous.
Je vous souhaite le meilleur pour cette nouvelle année.

J'ai un problème tout bête mais que je ne parviens pas à régler.
je dois supprimer des lignes sur des une vingtaines d'onglet (mais pas tous) selon une condition sur une colonne.

Sub Test()
Dim V_Sheet As Worksheet
Dim I As Integer
For Each V_Sheet In Worksheets
V_Sheet.Activate
If ActiveSheet.Name <> "Synthese" And ActiveSheet.Name <> "DATA" And ActiveSheet.Name <> "vigie" And ActiveSheet.Name <> "BDD" Then
For I = Range("i65536").End(xlUp).Row To 1 Step -1
If Cells(I, 2) <> "A2" Then Rows(I).Delete
Next I
End If
Next V_Sheet
End Sub

Ca mouline sans faire quoi que ce soit.
est ce quelqu'un sait a quoi c'est dû... ca devrait marcher pourtant :(

merci d'avance à ceux qui verront pourquoi
 

Jacky67

XLDnaute Barbatruc
bonjour et belle année 2019 à tous.
Je vous souhaite le meilleur pour cette nouvelle année.

J'ai un problème tout bête mais que je ne parviens pas à régler.
je dois supprimer des lignes sur des une vingtaines d'onglet (mais pas tous) selon une condition sur une colonne.

Sub Test()
Dim V_Sheet As Worksheet
Dim I As Integer
For Each V_Sheet In Worksheets
V_Sheet.Activate
If ActiveSheet.Name <> "Synthese" And ActiveSheet.Name <> "DATA" And ActiveSheet.Name <> "vigie" And ActiveSheet.Name <> "BDD" Then
For I = Range("i65536").End(xlUp).Row To 1 Step -1
If Cells(I, 2) <> "A2" Then Rows(I).Delete
Next I
End If
Next V_Sheet
End Sub

Ca mouline sans faire quoi que ce soit.
est ce quelqu'un sait a quoi c'est dû... ca devrait marcher pourtant :(

merci d'avance à ceux qui verront pourquoi
Bonjour,
Cette macro fait exactement ce qui est demandé.
Elle supprime toutes lignes dont la colonne B ==> Cells(I, 2) ne comportant pas "A2"==>(texte "A2")
Le tout à partir de la dernière ligne de la colonne I vers la ligne 1 de chaque feuille concernée (Range("i65536").End(xlUp).Row To 1 Step -1)


Bonne Année
 
Dernière édition:

herve62

XLDnaute Barbatruc
Supporter XLD
Bonjour
j'aime pas trop ta méthode "activate" , à éviter pour l'affichage !
Donc j'ai refait à ma sauce
Code:
Sub Test()
Dim I As Integer
nbsh = Sheets.Count
For x = 1 To nbsh
    If Sheets(x).Name <> "Synthese" And Sheets(x).Name <> "DATA" And Sheets(x).Name <> "vigie" _
    And Sheets(x).Name <> "BDD" Then
        For I = Range("i65536").End(xlUp).Row To 1 Step -1
            If Cells(I, 2) <> "A2" Then Rows(I).Delete
        Next I
    End If
Next x
End Sub
Je ne connais pas ton utilisation , la sub fonctionne j'ai testé avec des datas en B et en I , ça se supprime; regarde si c'est ok pour toi sinon : JOindre le fichier !!
 

Dranreb

XLDnaute Barbatruc
Bonjour et bonne année.
Essayez comme ça :
VB:
Option Explicit
Sub Test()
   Dim Wsh As Worksheet
   For Each Wsh In ThisWorkbook.Worksheets
      Select Case Wsh.Name
         Case "Synthèse", "DATA", "vigie concurrence", "BDD"
         Case Else:
            LignesOùRelat(Wsh.Rows(1), "B", "<>", "A2").Interior.Color = &HFFFF& ' Testez déjà si ça met en jaune les lignes qui seront à supprimer …
   '         LignesOùRelat(Wsh.Rows(1), "B", "<>", "A2").Delete
         End Select
      Next Wsh
   End Sub
Function ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal OPé As String, ByVal Valeur) As Range
Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
   On Error Resume Next
   Set ColLignesOùRelat = Intersect(LignesOùRelat(CelDéb, ColQuoi, OPé, Valeur), CelDéb.EntireColumn)
   End Function
Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal OPé As String, ByVal Valeur) As Range
Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
   If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
   If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
      """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
   On Error Resume Next
   Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & OPé & Valeur)
   End Function
Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
   On Error Resume Next
   Set ColLignesOùCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
   End Function
Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Rem. ——— Lignes entières partant de LigneDéb vérifiant une condition R1C1 CondR1C1.
   Dim Rng As Range
   Set Rng = PlageÀPartirDe(LigneDéb.EntireRow): If Rng Is Nothing Then Exit Function
   Set Rng = Rng.Columns(Rng.Columns.Count + 1)
   Application.ScreenUpdating = False
   On Error Resume Next
   Rng.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
   Set LignesOùCondR1C1 = Rng.SpecialCells(xlCellTypeFormulas, 1).EntireRow
   Rng.Delete xlShiftToLeft
   End Function
Function PlageÀPartirDe(ByVal CelDéb As Range) As Range
Rem. ——— Plage utilisée à partir de CelDéb.
   Dim NbrLig As Long, NBrCol As Long
   With CelDéb.Worksheet.UsedRange:
      NbrLig = .Row + .Rows.Count - CelDéb.Row
      NBrCol = .Column + .Columns.Count - CelDéb.Column
      If NbrLig <= 0 Or NBrCol <= 0 Then Exit Function
      End With
   Set PlageÀPartirDe = CelDéb.Resize(NbrLig, NBrCol)
   End Function
 

Dranreb

XLDnaute Barbatruc
Remarque, il y avait plusieurs erreurs dans le code de la Sub Test d'origine :
1) — Des noms de feuilles différents de celles à respecter ("Synthese" sans accent, "vigie" au lieu de "vigie concurrence")
2) — Range("i65536").End(xlUp): la colonne I est partout vide.
3) — Cells(I, 2) <> "A2" de la feuille active testée au lieu de la feuille Sheets(x)
En outre c'était très lent. Même mon code n'est déjà pas très rapide avec autant de lignes, alors le vôtre …
 

Jacky67

XLDnaute Barbatruc
hello !

je ne comprend pas pourquoi mais ca marche pas correctement.
je vous joins le fichier, je suis en train de devenir fou dans les tests...

merci
Bonjour à tous
Meilleurs vœux pour 2019
Autre proposition
Attention à l'orthographe des noms de feuille et au nom incomplet

Code:
Sub Test()
Dim Sh As Worksheet
Dim  Plage As Range
For Each Sh In ThisWorkbook.Worksheets
  If Sh.Name <> "Synthèse" And Sh.Name <> "DATA" And Sh.Name <> "vigie concurrence" And Sh.Name <> "BDD" Then
    With Sh
      .Rows(1).Insert
      .[a1] = "t1": .[b1] = "t2": .[c1] = "t3"
      Set Plage = .Range("A1").CurrentRegion
      Plage.AutoFilter Field:=2, Criteria1:="<>A2"
      Plage.SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
      Sh.Rows(1).Delete
    End With
  End If
Next
End Sub
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir douguy, Jacky67, herve62, Bernard,
Code:
Sub SuprimerLignes()
Dim t#, w As Worksheet
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next 'si aucune SpecialCell
For Each w In Worksheets
    If w.Name <> "Synthèse" And w.Name <> "DATA" And w.Name <> "vigie concurrence" And w.Name <> "BDD" Then
        With w.UsedRange.EntireRow
            .Columns(2).Insert
            .Columns(2) = "=1/(RC[1]=""A2"")"
            .Columns(2) = .Columns(2).Value 'supprime les formules
            .Sort .Columns(2), xlAscending, Header:=xlNo 'tri pour grouper et accélérer
            .Columns(2).SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
            .Columns(2).Delete xlToLeft
        End With
    End If
Next
Application.Calculation = xlCalculationAutomatic
MsgBox "Suppressions réalisées en " & Format(Timer - t, "0.00 \s")
End Sub
Exécution en 4 secondes chez moi.

A+
 

Pièces jointes

  • test macro(1).xlsm
    2.5 MB · Affichages: 8

herve62

XLDnaute Barbatruc
Supporter XLD
Je re Edite , pas vu la réponse de JOB75 , tant pis
J'avais pensé au tri , mais pas évident
-----------------------------------------------
Maintenant avec le fichier , on y voit plus clair !!
Il y a un truc qui m'échappe !! pourquoi faire un End(xlup) en I65000 ...ta colonne est vide ?
Autre ! erreurs de noms de feuille > synthèse, vigie concurrence
Donc pour bien vérifier j'ai revu ma macro et fait du pas à pas !
elle fonctionne , par contre lance la le soir avant de te coucher et reprend le lendemain
j'ai mis un chrono ( revalide le msgbox d'affichage) , en gros c'est 40min par feuille
Je cherche encore une méthode plus rapide .... mais rien
 

Pièces jointes

  • test macro_hd.xlsm
    2.6 MB · Affichages: 8

Discussions similaires

Réponses
5
Affichages
124

Statistiques des forums

Discussions
311 705
Messages
2 081 733
Membres
101 807
dernier inscrit
foued