Microsoft 365 Comparaison de 2 cellules contenant les mêmes mots en désordre

dauof

XLDnaute Nouveau
Bonjour,

je souhaite comparer deux cellules contenant plusieurs mots peut importe leurs ordres, exemple:
  • si la cellule A contient les mots:
  • années,mois,jour,heure
  • et que la cellule B contient :
  • heure,année,jour,mois
Alors le résultat est OK, dès lors que ces cellules contiennent les mêmes mots.

Je vous remercie par avance de votre retour.
 

fanch55

XLDnaute Barbatruc
Bonjour,
Une fonction par Vba :
On compare R1 à R2, tous les mots doivent correspondre
Si Include = Vrai, R1 peut être inclus dans R2 .
VB:
Option Explicit
Function SameStrings(R1 As String, R2 As String, Optional Include = False) As Boolean
Dim P1, P2
Dim N As Integer, I As Integer, J As Integer

    P1 = Split(Application.Trim(R1))
    P2 = Split(Application.Trim(R2))
     N = -1
    Select Case True
        Case UBound(P1) < 0
        Case UBound(P2) < 0
        Case (UBound(P1) < UBound(P2)) And Not Include
        Case (UBound(P1) > UBound(P2)) And Include
        Case Else
        For I = 0 To UBound(P1)
            For J = 0 To UBound(P2)
                If StrComp(P1(I), P2(J), vbTextCompare) = 0 Then
                    N = N + 1
                    Exit For
                End If
            Next
        Next
        SameStrings = N = UBound(P1)
    End Select
    
End Function
 

Pièces jointes

  • Dauof.xlsm
    16.5 KB · Affichages: 8
Dernière édition:

dauof

XLDnaute Nouveau
Bonjour franch55, merci pour pour la réponse.

ce que je remarque dans cette fonction, c'est que si la cellule A contient 2 mots et que la cellule B contient 3 mots dont les deux sont de la cellule A (même en désordre) alors le résultat est Vrai.
ça ne répond malheureusement pas à mon besoin, il faudrait que le résultat soit faux dès lors qu'on a un mot en plus.
aussi si la cellule contient des mots séparés par des virgules ça ne fonctionne pas non plus.

Je vous remercie par avance de votre retour.
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous :),

Une autre fonction:
VB:
Function QuifQuif(ByVal s1$, ByVal s2$) As Boolean
Dim t1, t2, x As Boolean, i&, j&
   t1 = Split(Application.Proper(Application.Trim(s1)))
   t2 = Split(Application.Proper(Application.Trim(s2)))
   If UBound(t1) <> UBound(t2) Then Exit Function
   For i = 0 To UBound(t2)
      x = False
      For j = 0 To UBound(t2): x = x Or (t1(i) = t2(j)): Next j
      If Not x Then Exit Function
   Next i
   QuifQuif = True
End Function

nota : ça risque d'être un peu plus compliqué si l'hypothèse retenue (l'espace est le seul séparateur) est fausse. Les séparateurs peuvent-ils être autres qu'un espace ?
 

Pièces jointes

  • Dauof- kifkif- v1.xlsm
    16.3 KB · Affichages: 5
Dernière édition:

fanch55

XLDnaute Barbatruc
ce que je remarque dans cette fonction, c'est que si la cellule A contient 2 mots et que la cellule B contient 3 mots dont les deux sont de la cellule A (même en désordre) alors le résultat est Vrai.
Étonnant, cela ne peut être vrai que si Include = vrai​
On compare R1 à R2, tous les mots doivent correspondre
Si Include = Vrai, R1 peut être inclus dans R2 .
1642673548723.png



aussi si la cellule contient des mots séparés par des virgules ça ne fonctionne pas non plus.
Spécification non demandée initialement .
La Fonction a été modifiée pour :
  • prendre en compte une liste de délimiteurs spécifiques par défaut
  • permettre d'indiquer sa propre liste
VB:
Option Explicit
Function SameStrings(R1 As String, R2 As String, _
                     Optional Include As Boolean = False, _
                     Optional Delimiteurs As String = " ,;:()'") _
         As Boolean
' ==========================================================================================
'   Tous les mots de R1 doivent se retrouver dans R2
'   si include est false le nombre de mots dans R1 et R2 doivent être identiques
'   sinon le nombre de mots de R1 peut être moins grand que celui de R2 (R1 inclus dans R2)
'   Si des délimiteurs sont précisés , ils remplacent ceux par défaut
' ==========================================================================================

    Dim P1, P2
    Dim N As Integer, I As Integer, J As Integer
    
    Delimiteurs = Delimiteurs & vbCrLf
    For I = 1 To Len(Delimiteurs)
        R1 = Replace(R1, Mid(Delimiteurs, I, 1), " ")
        R2 = Replace(R2, Mid(Delimiteurs, I, 1), " ")
    Next
    
    P1 = Split(Application.Trim(R1))
    P2 = Split(Application.Trim(R2))
     N = -1
    Select Case True
        Case UBound(P1) < 0
        Case UBound(P2) < 0
        Case (UBound(P1) < UBound(P2)) And Not Include
        Case (UBound(P1) > UBound(P2)) And Include
        Case Else
        For I = 0 To UBound(P1)
            For J = 0 To UBound(P2)
                If StrComp(P1(I), P2(J), vbTextCompare) = 0 Then
                    N = N + 1
                    Exit For
                End If
            Next
        Next
        SameStrings = N = UBound(P1)
    End Select
    
End Function
 

Pièces jointes

  • Dauof.xlsm
    20.1 KB · Affichages: 5
Dernière édition:

dauof

XLDnaute Nouveau
Bonjour Fanch55,

merci pour ce partage, effectivement je n'ai pas été clair dans ma demande, d'ailleurs j'ai oublié de mentionner le cas ou les cellules sont vides, c'est à dire avoir un vrai au lieu de faux. je suis nul dans le vba :), je trouve dommage qu'excel ne propose pas cela nativement. Merci de votre retour
 

fanch55

XLDnaute Barbatruc
j'ai oublié de mentionner le cas ou les cellules sont vides, c'est à dire avoir un vrai au lieu de faux.
Fonction corrigée pour renvoyer une chaine vide
VB:
Option Explicit
Function SameStrings(R1 As String, R2 As String, _
                     Optional Include As Boolean = False, _
                     Optional Delimiteurs As String = " ,;:()'") As Variant
         SameStrings = False
' ==========================================================================================
'   Tous les mots de R1 doivent se retrouver dans R2
'   si include est false le nombre de mots dans R1 et R2 doivent être identiques
'   sinon le nombre de mots de R1 peut être moins grand que celui de R2 (R1 inclus dans R2)
'   Si des délimiteurs sont précisés , ils remplacent ceux par défaut
' ==========================================================================================

    Dim P1, P2
    Dim N As Integer, I As Integer, J As Integer
   
    Delimiteurs = Delimiteurs & vbCrLf
    For I = 1 To Len(Delimiteurs)
        R1 = Replace(R1, Mid(Delimiteurs, I, 1), " ")
        R2 = Replace(R2, Mid(Delimiteurs, I, 1), " ")
    Next
   
    P1 = Split(Application.Trim(R1))
    P2 = Split(Application.Trim(R2))
     N = -1
    Select Case True
        Case UBound(P1) < 0: SameStrings = vbNullString
        Case UBound(P2) < 0: SameStrings = vbNullString
        Case (UBound(P1) < UBound(P2)) And Not Include
        Case (UBound(P1) > UBound(P2)) And Include
        Case Else
        For I = 0 To UBound(P1)
            For J = 0 To UBound(P2)
                If StrComp(P1(I), P2(J), vbTextCompare) = 0 Then
                    N = N + 1
                    Exit For
                End If
            Next
        Next
        SameStrings = N = UBound(P1)
    End Select
   
End Function

Si vous voulez que ce soit vrai plutôt qu'une chaine vide ( bien que je trouve cela illogique )
VB:
Option Explicit
Function SameStrings(R1 As String, R2 As String, _
                     Optional Include As Boolean = False, _
                     Optional Delimiteurs As String = " ,;:()'") As Variant
         SameStrings = False
' ==========================================================================================
'   Tous les mots de R1 doivent se retrouver dans R2
'   si include est false le nombre de mots dans R1 et R2 doivent être identiques
'   sinon le nombre de mots de R1 peut être moins grand que celui de R2 (R1 inclus dans R2)
'   Si des délimiteurs sont précisés , ils remplacent ceux par défaut
' ==========================================================================================

    Dim P1, P2
    Dim N As Integer, I As Integer, J As Integer
   
    Delimiteurs = Delimiteurs & vbCrLf
    For I = 1 To Len(Delimiteurs)
        R1 = Replace(R1, Mid(Delimiteurs, I, 1), " ")
        R2 = Replace(R2, Mid(Delimiteurs, I, 1), " ")
    Next
   
    P1 = Split(Application.Trim(R1))
    P2 = Split(Application.Trim(R2))
     N = -1
    Select Case True
        Case UBound(P1) < 0: SameStrings = True
        Case UBound(P2) < 0: SameStrings = True
        Case (UBound(P1) < UBound(P2)) And Not Include
        Case (UBound(P1) > UBound(P2)) And Include
        Case Else
        For I = 0 To UBound(P1)
            For J = 0 To UBound(P2)
                If StrComp(P1(I), P2(J), vbTextCompare) = 0 Then
                    N = N + 1
                    Exit For
                End If
            Next
        Next
        SameStrings = N = UBound(P1)
    End Select
   
End Function
 
Dernière édition:

dauof

XLDnaute Nouveau
Merci de votre aide, c'est parfait,.

J'aimerais améliorer la fonction, est ce qu'il possible d'afficher dans une autre cellule la mot manquant, par exemple

Cellule A: année, mois, jour, heure
Cellule B: jour, heure, mois
Cellule de comparaison: Faux (sans comparer les majuscules et minuscules dans les mots)
Cellule extraction du mot manquant: année

Je vous remercie de votre aide, elle m'est vraiment utile :)
 

patricktoulon

XLDnaute Barbatruc
bonsoir
extrait de l’adjuvant de ma fonction similaire (algorithme de leveinchtein )
VB:
Option Explicit
Function SameString2s(s1$, s2$, Optional casse = 0)
    Dim point As Double, p As Double, oz As Long, t1, t2, tbl
    If casse = 1 Then s1 = UCase(s1): s2 = UCase(s2) 'respecte la casse ou pas
    SameString2s = True
    If InStr(s1, " ") = 0 Then SameString2s = 0: Exit Function
    t1 = Split(Replace(s1, "-", " "), " "): t2 = Split(Replace(s2, "-", " "), " ")
    If UBound(t1) > UBound(t2) Then tbl = t1 Else tbl = t2: s2 = s1
    p = 100 / UBound(tbl)
    For oz = 0 To UBound(tbl): point = point + IIf(s2 Like "*" & tbl(oz) & "*", p, -p): Next
    If point < 100 Then SameString2s = False
End Function
=SameString2s(A1;B1;1)' ne respecte pas la casse
=SameString2s(A1;B1)'respecte la casse
1643217744201.png
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
bonsoir @fanch55
ma version a 2 possibilité soit avec casse soit sans casse
et ne change que le "-" pour " "
donc les guillemets , les virgules ,ect.... forcement vont exclure la chaîne
de plus si une chaîne est plus longue que l'autre la 1 ou la 2 le mot non existant dans l'autre va enlever x point selon le barème de 100 divisé par l'array le plus long
apres faut voir la regle souhaité et ses souplesse
ou carrément prendre ma fonction similaire et n'accepté qu'a partir de 95%
 

fanch55

XLDnaute Barbatruc
Bonjour,
C'est à vous de voir quelle est la fonction qui répond au mieux à votre demande .

Le classeur ci-joint répond au mieux à votre dernière demande .
La fonction est documentée :
1643382181213.png


Classeur Supprimé car petite omission dans le paramétrage, voir le post #22
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
299 952
Messages
1 980 342
Membres
207 062
dernier inscrit
K2OPA