XL 2019 conserver les lignes contenant du texte rouge

snipe49 · 28 Décembre 2023

Bonjour a tous

je cherche a conserver uniquement les lignes qui contiennent du texte rouge

ci joint mon fichier

merci d'avance pour votre aide

sylvanu · 28 Décembre 2023

Bonjour Snipe, Njhub,
Un essai en PJ avec :

VB:

Sub SupLignes()
    Dim ValMin, ValMax, DL, L
    Application.ScreenUpdating = False
    ValMin = Val(Split([V2].FormatConditions(2).Formula1, "=")(1))  ' Recup val min filtrage
    ValMax = Val(Split([V2].FormatConditions(3).Formula1, "=")(1))  ' Recup val max filtrage
    DL = [V100000].End(xlUp).Row                                    ' Dernière ligne
    For L = DL To 2 Step -1                                         ' Si <Valmin et >ValMax on supprime la ligne
        If Cells(L, "V") < ValMin Or Cells(L, "V") > ValMax Then Rows(L).Delete Shift:=xlUp
    Next L
End Sub

NB : Le bouton gris sert à ré initialiser le tableau pour les tests.

njhub · 28 Décembre 2023

Bonjour snipe49, le forum

Essayez avec une formule reprenant le paramétrage de vos formats conditionnels :

Code:

=SI(OU(J2<20;K2<20;L2<25,3;M2<25,3;N2<4;O2<4;P2>0,5;Q2>0,5;R2>0,3;V2<1378;V2>1381);LIGNE();"")

qui renvoie le n° de ligne quand l'une au moins des conditions est vérifiée

😉

snipe49 · 28 Décembre 2023

Désolé mais je comprends pas

J'y connais vraiment pas gand chose et j'ai déja bien galerer a faire ce fichier

sylvanu · 28 Décembre 2023

Bonjour Snipe, Njhub,
Un essai en PJ avec :

VB:

Sub SupLignes()
    Dim ValMin, ValMax, DL, L
    Application.ScreenUpdating = False
    ValMin = Val(Split([V2].FormatConditions(2).Formula1, "=")(1))  ' Recup val min filtrage
    ValMax = Val(Split([V2].FormatConditions(3).Formula1, "=")(1))  ' Recup val max filtrage
    DL = [V100000].End(xlUp).Row                                    ' Dernière ligne
    For L = DL To 2 Step -1                                         ' Si <Valmin et >ValMax on supprime la ligne
        If Cells(L, "V") < ValMin Or Cells(L, "V") > ValMax Then Rows(L).Delete Shift:=xlUp
    Next L
End Sub

NB : Le bouton gris sert à ré initialiser le tableau pour les tests.

snipe49 · 28 Décembre 2023

sylvanu à dit:

Bonjour Snipe, Njhub,
Un essai en PJ avec :

VB:

Sub SupLignes()
    Dim ValMin, ValMax, DL, L
    Application.ScreenUpdating = False
    ValMin = Val(Split([V2].FormatConditions(2).Formula1, "=")(1))  ' Recup val min filtrage
    ValMax = Val(Split([V2].FormatConditions(3).Formula1, "=")(1))  ' Recup val max filtrage
    DL = [V100000].End(xlUp).Row                                    ' Dernière ligne
    For L = DL To 2 Step -1                                         ' Si <Valmin et >ValMax on supprime la ligne
        If Cells(L, "V") < ValMin Or Cells(L, "V") > ValMax Then Rows(L).Delete Shift:=xlUp
    Next L
End Sub

NB : Le bouton gris sert à ré initialiser le tableau pour les tests.

Merci c'est bien ce que je veux par contre excel me bloque ta macro

sylvanu · 28 Décembre 2023

snipe49 à dit:
par contre excel me bloque ta macro

Autorisez les macros :

fanch55 · 28 Décembre 2023

Salut,
Code basique, on ne cherche pas ce qui cause quoi, on cherche la couleur ciblée :

VB:

Sub Sup_Rouge()
Dim Rw As Integer, Cl As Range
Const Target_Color = 393372 ' le rouge de la MFC
    For Rw = [Test].Rows.Count To 1 Step -1
        For Each Cl In [Test].Rows(Rw).Columns
            If Cl.DisplayFormat.Font.Color = Target_Color Then
                Cl.EntireRow.Delete
                Exit For
            End If
        Next
    Next
End Sub

snipe49 · 28 Décembre 2023

sylvanu à dit:
Autorisez les macros :
Regarde la pièce jointe 1187293

super merci
il a fallu que j'aille aussi dans les propriétés du fichier sous windows

snipe49 · 28 Décembre 2023

sylvanu à dit:

Bonjour Snipe, Njhub,
Un essai en PJ avec :

VB:

Sub SupLignes()
    Dim ValMin, ValMax, DL, L
    Application.ScreenUpdating = False
    ValMin = Val(Split([V2].FormatConditions(2).Formula1, "=")(1))  ' Recup val min filtrage
    ValMax = Val(Split([V2].FormatConditions(3).Formula1, "=")(1))  ' Recup val max filtrage
    DL = [V100000].End(xlUp).Row                                    ' Dernière ligne
    For L = DL To 2 Step -1                                         ' Si <Valmin et >ValMax on supprime la ligne
        If Cells(L, "V") < ValMin Or Cells(L, "V") > ValMax Then Rows(L).Delete Shift:=xlUp
    Next L
End Sub

NB : Le bouton gris sert à ré initialiser le tableau pour les tests.

Petite question
A quoi sert ta feuille REF?

snipe49 · 28 Décembre 2023

Cousinhub à dit:
Re-,
Pour info, une simple mise à jour de la requête nécessitera de re-dérouler le code...
Alors que ce serait faisable dès la requête...
Bref, à toi de voir...

J'ai déjà essayé mais ça fonctionne pas
Et j'ai plus de 60 fichiers sources
Je vais les chercher a partir d'un dossier

snipe49 · 28 Décembre 2023

Cousinhub à dit:
Re-,
Ok, tu as essayé...
Qui te dit que nous ne pourrions y arriver?
Et le nombre de fichiers importe peu...
Si tu pouvais ne mettre que 2 ou 3 fichiers, on pourrait t'indiquer la façon de faire, peut-être?
Les fichiers dans un zip, afin de pouvoir être mis en ligne
Si ça t'intéresse, bien sûr...

Mais je suis bon d'accord que moi j'y arrives pas
Je doute pas de vos capacités
voila les fichiers au complet

snipe49 · 28 Décembre 2023

Cousinhub à dit:
Re-,
Dans le fichier "TR_1001_BO_bj015_ES_201988.CSV", tu n'as aucune opération, c'est normal?
Normalement, en colonne E, il y a les opérations, sauf dans celui-là...
J'ai donc rajouté les 3 opérations "normales"...
Et dans le fichier "TR_1003_BO_bi001_ES_17817.CSV", il n'y a aucune mesure pour le voile droit en colonne S...
Dans la requête, je remplace donc l'error par un "Manque mesure" en colonne AA
Dans le fichier joint, tu renseignes le chemin du dossier dans l'onglet "Paramètres", dans la cellule A2.
Tous les CSV sont chargés.
Dans la requête, je n'ai effectué aucun filtre final, je te laisse le faire (si tu ne veux conserver que les "OK", ou les "KO" et "Manque mesure", tu as le choix)
Si tu n'y arrives pas, reviens
Bonne soirée

Alors oui j'avais compilé mon fichier zip au tout début avant de revérifier toutes mes données.
Dans mes fichiers sources les infos sont bonnes.

Merci de ton aide

sylvanu · 29 Décembre 2023

Bonsoir,

snipe49 à dit:
A quoi sert ta feuille REF?

A rien. Simplement cela permet de copier le tableau dans la feuille Test ... pour faire des tests. ( bouton gris )

mapomme · 29 Décembre 2023

Bonjour à tous,

snipe49 à dit:
je cherche a conserver uniquement les lignes qui contiennent du texte rouge

Pour le fun, une piste de macro :

VB:

Sub NiNoirNiBlanc()
Dim lst As ListObject, i&, x, dpf, BW As Boolean
   Application.ScreenUpdating = False
   Set lst = Sheets("test").Range("a1").ListObject
   For i = lst.ListRows.Count To 1 Step -1
      BW = True
      For Each x In lst.ListRows(i).Range
         If x <> "" Then
            dpf = x.DisplayFormat.Font.Color
            If dpf <> vbBlack And dpf <> vbWhite Then BW = False: Exit For
         End If
      Next x
      If BW Then lst.ListRows(i).Delete
   Next i
End Sub

Cousinhub · 29 Décembre 2023

Bonjour,
C'est moi ou????
Tu valides une réponse qui fait exactement l'inverse de la demande, et qui ne traite qu'une colonne (la V), alors que tes MEFC concernent 11 colonnes...
Bah, passe de bonnes fêtes, et meilleurs vœux

XL 2019 conserver les lignes contenant du texte rouge

snipe49

XLDnaute Nouveau

Pièces jointes

sylvanu

njhub

XLDnaute Occasionnel

snipe49

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

snipe49

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

snipe49

XLDnaute Nouveau

snipe49

XLDnaute Nouveau

snipe49

XLDnaute Nouveau

snipe49

XLDnaute Nouveau

Pièces jointes

snipe49

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Cousinhub

XLDnaute Barbatruc

Discussions similaires

XL 2019 conserver les lignes contenant du texte rouge

XLDnaute Nouveau

Pièces jointes

XLDnaute Occasionnel

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency