XL 2016 Comparer des chiffres possédant le même titre

[Erakmur]

Bonjour,
Dans le fichier excel en pièce jointe, je souhaite savoir pour le même titre colonne A, si le nombre colonne B est plus grand ou plus petit. Les titres sont des successions de caractères aléatoires. De temps en temps, un même titre apparait (exemple ici colonne A ou le f apparait 3 fois). En colonne C, je souhaietrai voir apparaitre OK quand le chiffre de la ligne la plus élevé et plus grand que le chiffre de la ligne précédente pour le même titre et Nok sinon. Dans cette exemple, 1 n'est pas supérireure à 12 donc Nok mais 12 est bien supérieur à 11 donc ok. Il n'y aura rien en C7 parce que pas de f avant pour faire la comparaison.
Dans cette exemple, je me limite à 41 lignes mais le tableau peut contenir des milliers de ligne. Dans l'idéal, il me faudrait une formule à mettre en C2 que je fais glisser. Il n'est pas possible de trier les colonnes.
Quelqu'un a t'il une solution ?
Cordialement

 

[mapomme]

Bonsoir @Erakmur

Avec une fonction personnalisée, c'est relativement simple (me semble-t-il).

La fonction : =EstSup(Titre, MajDiffMin)

• titre est la cellule à comparer aux titres et valeurs précédentes
• si le 2ème paramètre MajDiffMin est omis., alors on ne distingue pas les majuscules des minuscules

Voir les formiules en C2 et D3 à recopier vers la bas

Le code de la fonction dans module1 :

F
Function EstSup(ByVal Titre, Optional MajDiffMin) As String
Application.Volatile
'Titre est le titre pour lequel on va comparer la valeur avec la valeur de la ligne précédente de même titre
'la valeur est toujours dans la cellule à droite des titres
'le second paramètre s'il est présent (et vaut n'importe quoi) force les comparaison à disntinguer
'les majuscules des minuscules ("Aa" est différent de "aa")
'si le second paramètre est omis, on ne distingue pas les majuscules des minuscules( "Aa" est égal à "aa")
Dim t, i&, i0&
   EstSup = ""
   With Application.Caller.Parent
      i0 = Application.Caller.Row
      t = Range("a1:b" & i0)
      If IsMissing(MajDiffMin) Then
         For i = 1 To UBound(t): t(i, 1) = LCase(t(i, 1)): Next
         Titre = LCase(Titre)
      End If
      For i = i0 - 1 To 2 Step -1
         If t(i, 1) = Titre Then EstSup = IIf(t(i0, 2) < t(i, 2), "Nok", "ok"): Exit Function
      Next i
   End With
End Function

 

[job75]

Bonjour Erakmur, mapomme, le forum,

Sélectionner C2 et dans le Gestionnaire de noms définir le nom lig par :

=GRANDE.VALEUR(SI(Feuil1!$A$1:$A2=Feuil1!$A2;LIGNE(Feuil1!$A$1:$A2));2)

Formule en C2 :

=SIERREUR(SI(INDEX(B$1:B2;lig)<B2;"OK";"NOK");"")

Formule en D2 pour repérer la ligne précédente :

=SIERREUR(lig;"")

La casse est ignorée mais si l'on veut qu'elle soit respectée on utilisera la fonction EXACT au lieu de l'égalité dans la définition de lig.

A+

 

[job75]

Pour tester j'ai recopié la plage A2:C41 sur 20 000 lignes.

Et j'ai rendu les formules volatiles en concaténant T(ALEA()).

Durées des recalculs chez moi sur Win 11 Excel 2019 :

- formule =T(ALEA())&estsup(A2) pour le post #2 => 109 secondes

- formule =T(ALEA())&SIERREUR(SI(INDEX(B$1:B2;lig)<B2;"OK";"NOK");"") pour le post #3 => 7,7 secondes.

Les durées étant calculées par cette macro dans le code de la feuille :

Sub a()
Dim t
t = Timer
Calculate
MsgBox Timer - t
End Sub

 

[mapomme]

Bonjour à tous , bonjour @job75 ,

Voici une procédure plus rapide qui recalcule les "ok" et "Nok".
Le recalcul se produit si une donnée a été modifiée dans les colonnes A ou B.
On fait aussi un premier calcul quand le fichier s'ouvre.

Pour 20 000 lignes, le calcul prend environ 0,20 s.

Le code principal est dans le module de la feuille Feuil:

Option Explicit

Const DistinguerMajMin = False      'si False alors on distingue les majucules des minuscules

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Columns("a:b")) Is Nothing Then ComparerAvecPrecedent
End Sub

Public Sub ComparerAvecPrecedent()
Dim der&
   Application.ScreenUpdating = False
   With Me
      If .FilterMode Then .ShowAllData
      der = .UsedRange.Row + .UsedRange.Rows.Count - 1
      If .Range("d1") = "à supprimer" Then Columns("d:d").Clear Else Columns("d:d").Insert
      .Range("d1") = "à supprimer"
      .Range("d2:d" & der).FormulaR1C1 = "=row()"
      .Range("d2:d" & der).Value = .Range("d2:d" & der).Value
      .Range("a1:d" & der).Sort key1:=.Range("a1"), order1:=xlAscending, Header:=xlYes, MatchCase:=IIf(DistinguerMajMin = False, False, True)
      .Range("c2:c" & der).FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],IF(RC[-1]>R[-1]C[-1],""ok"",""nok""),"""")"
      .Range("c2:c" & der).Value = .Range("c2:c" & der).Value
      .Range("a1:d" & der).Sort key1:=.Range("d1"), order1:=xlAscending, Header:=xlYes, MatchCase:=False
      If .Range("d1") = "à supprimer" Then .Columns("d:d").Delete
   End With
End Sub

Ainsi qu'un petit bout dans le module de ThisWorkbook pour le lancement à l'ouverture du fichier:

Private Sub Workbook_Open()
   Feuil1.ComparerAvecPrecedent
End Sub

 

[job75]

Une autre solution VBA, très rapide grâce aux tableaux VBA et au Dictionary :

Sub Calcul()
Dim d As Object, tablo, resu(), i&, x, y, s
Set d = CreateObject("Scripting.Dictionary")
With Feuil1 'CodeName
    tablo = .[A1].CurrentRegion.Resize(, 2)
    ReDim resu(1 To UBound(tablo), 1 To 2)
    resu(1, 1) = "Test": resu(1, 2) = "N° ligne"
    For i = 2 To UBound(tablo)
        x = tablo(i, 1): y = tablo(i, 2)
        If d.exists(x) Then
            s = Split(d(x), Chr(1))
            resu(i, 1) = IIf(y > Val(Replace(s(0), ",", ".")), "OK", "NOK")
            resu(i, 2) = Val(s(1))
            d.Remove x
        End If
        d(x) = y & Chr(1) & i
    Next
    '---restitution---
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .[C1].Resize(UBound(resu), 2) = resu
End With
End Sub

Il n'y a aucun tri.

Chez moi sur 20 000 lignes la durée d'exécution est 0,17 seconde.

 

[mapomme]

Salut @job75

En ce moment, bien que je les apprécie beaucoup, j’essaye de ne plus utiliser les "dictionary" pour être indépendant des plateformes (PC ou Apple). Je sens que ce ne sera qu'une "lubie" passagère, un égarement fugace .

Bonne journée à toi

 

[job75]

Si l'on veut que la macro puisse fonctionner sur Windows et sur MAC on peut utiliser une collection :

Sub Calcul()
Dim tablo, resu(), i&, x, y, col As New Collection, s
With Feuil1 'CodeName
    tablo = .[A1].CurrentRegion.Resize(, 2)
    ReDim resu(1 To UBound(tablo), 1 To 2)
    resu(1, 1) = "Test": resu(1, 2) = "N° ligne"
    For i = 2 To UBound(tablo)
        x = tablo(i, 1): y = tablo(i, 2)
        On Error Resume Next
        col.Add y & Chr(1) & i, CStr(x)
        If Err Then
            s = Split(col(x), Chr(1))
            resu(i, 1) = IIf(y > Val(Replace(s(0), ",", ".")), "OK", "NOK")
            resu(i, 2) = Val(s(1))
            col.Remove x
            col.Add y & Chr(1) & i, CStr(x)
        End If
    Next
    '---restitution---
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .[C1].Resize(UBound(resu), 2) = resu
End With
End Sub

C'est à peine moins rapide => 0,20 seconde chez moi sur 20 000 lignes.

 

[mapomme]

Re @job75 ,

Tiens ,je pensais que ce serait quand même un peu plus long que simplement 3 centièmes de plus. Comme quoi, j'ai des idées préconçues à revoir sur les collections.

 

[job75]

Dans les autres discussions où j'utilisais une collection je mettais On Error Resume Next tout au début.

Puis Err = 0 avant l'ajout de l'item, et c'est cette instruction qui prend du temps.

Ici avec Err = 0 la durée passe à 4,5 secondes sur 20 000 lignes.

 

[Erakmur]

Bonjour,
Ca marche à la perfection. J'ai préféré prendre la solution de job75. En effet, je document étant évolutif, il se peut que je dois changer la formule régulièrement et la solution de job75 est la seul que je comprenne et que je peux modifier à ma guise. Je vous remercie pour votre aide, vous m'avez fait gagner un temps précieux.

 

[job75]

Bonjour Erakmur, le forum,

Quelle solution utilisez-vous ? Celle par formules du post #3 ou le VBA du post #6 ?

A+

 

[Erakmur]

Bonjour,
Celle par formule parce que je peux la modifier facilement.