Boucler sur lignes filtrées
Bonjour,
J'utilise un tableau au dessus duquel plusieurs boutons activant des filtres avancés sont utilisés.
En plus de filtrer sur les lignes concernées, la macro doit également colorer les éléments.
Mon code actuel marche bien sauf si la filtre ne donne aucun résultat...
Sub Wip()
With ActiveSheet
FiltreBS 'Active le filtre avancé
For Each Ligne In Range([A12], [I12].End(xlDown)).SpecialCells(xlCellTypeVisible).Rows 'Mon tableau va de A12 à J(nb de lignes variables)
Ligne.Cells(8).Interior.ColorIndex = 12
Ligne.Cells(9).Interior.ColorIndex = 12
Next Ligne
End With
End Sub
En effet si aucune ligne ne répond au filtre, la macro mouline car elle colore sans s'arrêter toutes les cases H et I des lignes vides situées en dessous du tableau ==> ça plante !
J'ai ensuite tenté de tester sur le nombre d'occurence avant de boucler mais ça plante de la même façon...
If (WorksheetFunction.Subtotal(3, Columns(3))) > 1 Then
Je pense que que le range de lignes sélectionnées dans ma boucle n'est pas adéquat.
Une solution ?
Merci pour votre aide,
waxscud
Hello,
Avec ça par exemple :
Sub passelignecache()
Dim c As Double
Dim cell As Range
c = 1
For i = 1 To 3
If Rows(c).Hidden = False Then 'si ligne cachée passe
Cells(c, 1).Interior.ColorIndex = 5
End If
c = c + 1
Next i
End Sub
+
Et pour empêcher de lancer la macro quand il n'y a aucune ligne dans le tableau, ajoute une sécurité en début de macro, par exemple :
Dim tailletab As Double
tailletab = Range("A1", Range("A1").End(xlDown)).Rows.Count 'donne la taille du tableau
If tailletab <= 0 Or tailletab >= 1048000 Then 'si atteint le chiffre des numéros de ligne de fin de classeur
End 'si la taille du tableau donne 0 ligne ou ligne de fin de classeur alors arrêt de la macro
End If
Amélioration du temps de traitement :
Ajoute en dessous des variables :
Application.ScreenUpdating = False
Au dessus de End Sub
Application.ScreenUpdating = True
Code Finale tout assemblé sur un tableau à 1 colonne avec 2200 lignes, temps de traitement moins d'une seconde.
Sub passelignecache()
Dim c As Double
Dim cell As Range
Dim tailletab As Double
Application.ScreenUpdating = False
tailletab = Range("A1", Range("A1").End(xlDown)).Rows.Count 'donne la taille du tableau
If tailletab <= 0 Or tailletab >= 1048000 Then 'taille du tableau = 0 ou atteint le chiffre des numéro de ligne de fin de classeur
End 'si la taille du tableau donne 0 ligne ou numéro de ligne de fin de classeur alors arrêt de la macro
End If
c = 2
For i = 2 To tailletab
If Rows(c).Hidden = False Then 'si ligne cachée passe
Cells(c, 1).Interior.ColorIndex = 5
End If
c = c + 1
Next i
Application.ScreenUpdating = True
End Sub
Bonjour waard,
Je n'ai pas pu tout récupérer de ton code mais j'ai réussi à m'en sortir avec ton option Ligne.Hidden.
Merci beaucoup !
Ci-dessous, mon code qui fonctionne
A+
Waxscud
Sub Wip()
With ActiveSheet
FiltreBS
If (WorksheetFunction.Subtotal(3, Columns(3))) > 1 Then
For Each Ligne In Range("A12").CurrentRegion.Offset(1).Rows
If Ligne.Hidden = False And Ligne.Cells(9) <> "" Then
Ligne.Cells(8).Interior.ColorIndex = 45
Ligne.Cells(9).Interior.ColorIndex = 45
End If
Next Ligne
Else
End If
End With
End Sub