Ressemblance entre plusieurs chaînes de caractères

[alex0909]

Bonjour à tous,

Je planche sur ce sujet depuis quelques temps.

J'ai besoin de matcher une cellule avec la valeur correspondante la plus proche dans une Base de donnée.

La valeur de la cellule contient du texte et accessoirement des caractères spéciaux et/ou nombres. Exemples :
- Boulogne Bil/1
- 11ASNIERES S/ SEI

Ces valeurs devraient ici être matchées avec les valeurs de la base de donnée:
-Boulogne Billancourt
-Asnières sur seine
Ou le cas échéant, la formule proposerait les valeurs les plus proches de la base de données (par exemple pour Boulogne Bil/1) :
- Boulogne Billancourt
- Boulogne sur Mer

J'ai essayé d'utiliser sans succès pour nos besoins :
https://www.excel-downloads.com/thr...emblante-entre-une-cellule-et-une-bdd.204024/
En effet la solution proposée recherche une correspondance exacte de la valeur recherchée.

Ci-dessous un extrait de l'excel pour mieux illustrer mon problème.

Merci de votre aide !

 

[PMO2]

Re : Ressemblance entre plusieurs chaînes de caractères

Bonjour,

Peut être une piste avec le code suivant à copier dans un module Standard

Sub aa()
Const NB_CAR As Long = 4
'---
Dim A$
Dim B$
Dim C$
Dim var
Dim k&
Dim i&
Dim myColl As New Collection

'---
A$ = CStr(ActiveCell)
If A$ = "" Then Exit Sub
var = Sheets("BDD").[a1].CurrentRegion
'---
For k& = 1 To Len(A$) - NB_CAR
  B$ = Mid(A$, k&, NB_CAR + k& - 1)
  For i& = 2 To UBound(var, 1)
    If InStr(1, UCase(var(i&, 1)), UCase(B$)) > 0 Then
      On Error Resume Next
      C$ = var(i&, 1) & Space(5) & var(i&, 2)
      myColl.Add C$, C$
      On Error GoTo 0
    End If
  Next i&
Next k&
'---
C$ = ""
For i& = 1 To myColl.Count
   C$ = C$ & myColl(i&) & vbCrLf
Next i&
If C$ <> "" Then MsgBox C$
End Sub

 

[alex0909]

Re : Ressemblance entre plusieurs chaînes de caractères

Bonjour, c'est exactement ce dont j'ai besoin !

Par contre pour aller jusqu'au bout de l'exercice j'aurais besoin de sélectionner la ligne qui correspond à la bonne ville dans la fenêtre des choix qui apparaît (ou de pouvoir dire qu'aucun choix ne me convient).
Cette action (le choix d'une des propositions) lancerait dans la foulée le match de la cellule d'en dessous, sans avoir à recliquer sur le bouton (en réalité j'ai plusieurs centaines de lignes à tester).

Une fois la bonne proposition sélectionnée, on peut aller jusqu'à la restituer dans les colonnes suivantes sur l'onglet "Cellules à matcher" ? Ex : la ville en colonne B et le code postal en colonne C ?

Si quelqu'un pouvait m'aider ce serait top !

 

[PMO2]

Re : Ressemblance entre plusieurs chaînes de caractères

OK, c'est possible.
Je regarde cela quand j'aurai le temps.
En revanche, il me faudrait votre classeur (édulcoré éventuellement des données sensibles) pour me référer à son exacte structure.
A plus.

 

[alex0909]

Re : Ressemblance entre plusieurs chaînes de caractères

Bonjour PMO2, merci pour votre réponse !

Le format du classeur reste le même, il est seulement bien plus lourd et est donc refusé quand j'essaie de l'importer. J'ai essayé votre module sur une base plus large, cela semble bien fonctionner.

Je pense qu'avec les trois modifications (Choix du résultat par contrôle visuel, restitution et passage à la cellule inférieure) cela sera d'une grande aide et je pourrais me débrouiller à partir d'ici.

Je vous ai mis dans cet Excel (ci-dessous) la forme attendue dans le premier classeur.

Merci encore pour votre aide.

 

[PMO2]

Re : Ressemblance entre plusieurs chaînes de caractères

Bonjour,

Essayez les codes suivants.
Code à copier dans la fenêtre de code de la feuille "Cellules à matcher"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim S As Worksheet
Dim OL As OLEObject
Dim R As Range
Dim var
Dim i&
Dim Pos&
Dim A$
Dim bool As Boolean
'---
Set S = ActiveSheet
For Each OL In S.OLEObjects
  If OL.progID = "Forms.ComboBox.1" Then
    OL.Cut
    Set OL = Nothing
  End If
Next OL
'---
With myColl
  Do Until .Count = 0
    .Remove .Item(.Count)
  Loop
End With
'---
Set R = S.[a1].CurrentRegion
var = R
For i& = 2 To UBound(var, 1)
  A$ = CStr(var(i&, 2))
  Pos& = InStr(1, A$, SEPARATEUR)
  If Pos& > 0 Then
    var(i&, 2) = Mid(A$, 1, Pos& - 1)
    var(i&, 3) = Mid(A$, Pos& + Len(SEPARATEUR))
    bool = True
  End If
Next i&
If bool Then
  Application.EnableEvents = False
  R = var
  Application.EnableEvents = True
End If
'/////////////////
With Target
  If .Rows.Count > 1 Or .Columns.Count > 1 Then Exit Sub
  If .Row = 1 Or .Column > 1 Or Trim(.Value) = "" Then Exit Sub
End With
'---
Call CreeCollection
If myColl.Count > 0 Then Call CreeComboBox
End Sub

Code à copier dans un module Standard

'//////////////////////////////////////////
'/// Nécessite la librairie suivante    ///
'/// (faire menu Outils/Références...)  ///
'/// Library MSForms                    ///
'/// C:\WINDOWS\system32\FM20.DLL       ///
'/// Microsoft Forms 2.0 Object Library ///
'//////////////////////////////////////////

'### Constantes à adapter ###
Public Const SHEET_BDD As String = "BDD"
Public Const NB_CAR As Long = 4
Public Const SEPARATEUR As String = "          "
'############################

Public myColl As New Collection

Sub CreeComboBox()
Dim OL As OLEObject
Dim CB As ComboBox
Dim R As Range
Dim i&
Dim T()
'---
Set R = ActiveCell.Offset(0, 1)
Set OL = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
        DisplayAsIcon:=False, Left:=R.Left, Top:=R.Top, Width:=R.Width + R.Offset(0, 1).Width, Height:=R.Height + 5)
Set CB = OL.Object
'---
If myColl.Count > 0 Then
  ReDim T(1 To myColl.Count)
  For i& = 1 To myColl.Count
    T(i&) = myColl.Item(i&)
  Next i&
End If
'---
CB.List = T
CB.LinkedCell = R.Address
'---
Set OL = Nothing
Set CB = Nothing
End Sub

Sub CreeCollection()
Dim A$
Dim B$
Dim C$
Dim var
Dim k&
Dim i&
'---
A$ = CStr(ActiveCell)
If A$ = "" Then Exit Sub
var = Sheets("BDD").[a1].CurrentRegion
'---
For k& = 1 To Len(A$) - NB_CAR
  B$ = Mid(A$, k&, NB_CAR + k& - 1)
  For i& = 2 To UBound(var, 1)
    If InStr(1, UCase(var(i&, 1)), UCase(B$)) > 0 Then
      On Error Resume Next
      C$ = var(i&, 1) & SEPARATEUR & var(i&, 2)
      myColl.Add C$, C$
      On Error GoTo 0
    End If
  Next i&
Next k&
End Sub

 

[alex0909]

Re : Ressemblance entre plusieurs chaînes de caractères

Bonjour PMO2,

Merci beaucoup pour cet outil, je vais me pencher plus en détail dessus mais c'est vraiment ce qu'il me fallait et je pense qu'il sera certainement utile à d'autres personnes.


Bonne journée.