XL 2010 suppression de ligne si la valeur ne correspond pas au texte contenu dans un tableau VBA

ricorico

XLDnaute Nouveau
Bonjour,

Je suis à la recherche d'une fonction VBA me permettant de supprimer les lignes qui ne contiennent pas le texte que j'ai ajouté dans un tableau VBA.

Je dispose d'un Excel qui se génère toutes les semaines avec dans la colonne A des catégories qui peuvent changer de place (il peut avoir des catégories qui s'ajoutent ou se suppriment en fonction des semaines) et dans les colonnes suivantes des valeurs numériques.

J'aimerai créer une macro qui me permet de garder seulement les lignes qui m'intéresse, peu importe leur emplacement dans la colonne A. J'ai créer un tableau avec la fonction Array qui contient les catégories que je souhaite garder.

Y'a t'il une fonction qui permet de comparer la cellule A2 avec toutes les valeurs de mon tableau, si la catégories correspond, alors on passe à la cellule A3, sinon on supprime la ligne et ainsi de suite.

Je ne sais pas si je suis très clair, si vous avez des questions n'hésitez pas
 
Solution
Bonjour

Une autre, toujours avec la liste des lignes a garder en Feuil1:
VB:
Sub Autre()
Dim D As Object
Dim i&

Set D = CreateObject("Scripting.dictionary")

With Sheets("Feuil1")
    For i = 2 To .Cells(.Rows.Count, 1).End(3).Row
        D(.Cells(i, 1)) = ""
    Next i
End With

With Sheets("UPTIME PAR TOOL SET")
    For i = .Cells(.Rows.Count, 1).End(3).Row To 2 Step -1
        If Not D.Exists(.Cells(i, 1)) Then .Rows(i).Delete
    Next i
End With
End Sub

Cordialement

Efgé

XLDnaute Barbatruc
Bonjour

Une autre, toujours avec la liste des lignes a garder en Feuil1:
VB:
Sub Autre()
Dim D As Object
Dim i&

Set D = CreateObject("Scripting.dictionary")

With Sheets("Feuil1")
    For i = 2 To .Cells(.Rows.Count, 1).End(3).Row
        D(.Cells(i, 1)) = ""
    Next i
End With

With Sheets("UPTIME PAR TOOL SET")
    For i = .Cells(.Rows.Count, 1).End(3).Row To 2 Step -1
        If Not D.Exists(.Cells(i, 1)) Then .Rows(i).Delete
    Next i
End With
End Sub

Cordialement
 

Efgé

XLDnaute Barbatruc
Bonjour à toutes et tous, le fil, le forum
De retour de congés je laisse une version plus "propre" et surtout plus rapide sur un grand nombre de lignes.
Lancement du code par alt+F8
VB:
Sub Autre_2()
Dim D As Object, Rng As Range
Dim i&, j&, Rw&
Dim Treport As Variant

Set D = CreateObject("Scripting.dictionary")
With Sheets("UPTIME PAR TOOL SET")
    Set Rng = .Range(.Cells(2, 1), .Cells(.Cells(Rows.Count, 1).End(3).Row, .Cells(1, Columns.Count).End(1).Column))
End With
Treport = Rng
 
With Sheets("Feuil1")
    For i = 2 To .Cells(.Rows.Count, 1).End(3).Row
        D(Trim(UCase(.Cells(i, 1)))) = ""
    Next i
End With

For i = LBound(Treport, 1) To UBound(Treport, 1)
    If D.exists(Trim(UCase(Treport(i, 1)))) Then
        Rw = Rw + 1
        For j = LBound(Treport, 2) To UBound(Treport, 2)
            Treport(Rw, j) = Treport(i, j)
        Next j
    End If
Next i

Application.ScreenUpdating = False
    Rng.Offset(Rw).Delete
    If Rw Then Rng.Resize(Rw, UBound(Treport, 2)) = Treport
Application.ScreenUpdating = True

End Sub

Cordialement
 

Pièces jointes

  • Supr_Lignes.xlsm
    29.9 KB · Affichages: 10
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 732
Messages
2 081 995
Membres
101 857
dernier inscrit
mt60400