Alex non ha risposto alla macro pubblicata da Flash o con quanto linkato da Sasyjoe, quindi non so se il problema puo' considerarsi risolto.
Comunque pubblico l' adattamento della conversione in vba di un lavoro fatto in gwbasic "qualche anno fa", che serviva a ritrovare le similitudini in un elenco di record.
Il codice:
- Codice: Seleziona tutto
Sub fuzzy(ByVal myStr As String, Optional ByVal MinPol As Long = 2)
'(c) by Anthony47
'myStr e' la stringa che sara' controllata nell' elenco
'MinPol e' la minima lunghezza del polinomio che sara' usata per i confronti; 2 di default
'Richiamare quindi con Call fuzzy(myStr ,[MinPol])
'
Dim CheckArea As String, Cell As Range, myString As String, mySString As String, CellaV As String
Dim I As Long, J As Long, myScore As Long, MaxJ As Long, LastR As Long
Dim VRis(), SimilArea As String, SimilNum As Long
'
myString = UCase(Replace(myStr, " ", ""))
If Len(myString) < MinPol Then MinPol = Len(myString)
'Qualche informazione sul problema:
CheckArea = "A2" '<<< Inizio dell' elenco su cui cercare
SimilArea = "C2" '<<< Inizio dell' area su cui si scriveranno i dati simili
SimilNum = 7 '<<< Numero di similitudini che saranno riportate
'
LastR = Cells(Rows.Count, Range(CheckArea).Range("A1").Column).End(xlUp).Row
ReDim VRis(1 To LastR)
For KK = 1 To LastR + 1 - Range(CheckArea).Range("A1").Row
myScore = 0: CellaV = UCase(Replace(Range(CheckArea).Range("A1").Offset(KK - 1, 0).Value, " ", ""))
For I = 1 To Len(myString)
If Len(CellaV) < (Len(myString) - I + 1) Then MaxJ = Len(CellaV) Else MaxJ = Len(myString) - I + 1
For J = MaxJ To MinPol Step -1
mySString = Mid(myString, I, J)
If Len(CellaV) <> Len(Replace(CellaV, mySString, "")) Then
myScore = myScore + (J * J)
If mySString = CellaV Then
myScore = myScore + (J * J * J * J)
End If
Exit For
End If
Next J
Next I
VRis(Range(CheckArea).Range("A1").Offset(KK - 1, 0).Row) = Round(myScore + 0.1 / KK, 6) - Abs((Len(CellaV) - Len(myString)) / (Len(myString) + 1))
'SCOMMENTARE la prossima per avere lo score accanto alla lista
' Range(CheckArea).Range("A1").Offset(KK - 1, 1) = myScore + 0.1 / KK
Next KK
'Output Risultati
Range(SimilArea).Resize(SimilNum, 2).ClearContents
For I = 1 To SimilNum
mypos = Application.Match(Application.WorksheetFunction.Large(VRis(), I), VRis(), 0)
If Not IsError(mypos) And Application.WorksheetFunction.Large(VRis(), I) > 0.1 Then
Range(SimilArea).Offset(I - 1, 0) = Cells(mypos, Range(CheckArea).Column)
Range(SimilArea).Offset(I - 1, 1) = Round(Application.WorksheetFunction.Large(VRis(), I), 0)
End If
Next I
'Crea un named range
Range(SimilArea).Resize(SimilNum).Name = "Simili"
End Sub
Si richiama da una' altra macro, ad esempio io ho usato
- Codice: Seleziona tutto
Sub testfuzzy()
Call fuzzy(Range("B1").Value, Range("C1").Value)
End Sub
L' ambiente di test con relativi risultati e' questo:
Uploaded with
ImageShack.usIn B1 la stringa da ricercare, in C1 la lunghezza minima dei polinomi di confronto; in colonna A le voci in cui ricercare.
In C2 e sottostanti le similitudini ritrovate; in D2 e sottostanti il coefficiente di similitudine (da confrontare con gli altri punteggi nella lista).
La macro inoltre crea un Intervallo con nome Simili che puo' essere usata come riferimento per l' elenco di una cella con convalida, o OrigineDati per una Combobox o una ListBox e simili.
Se usate il codice vi invito a non modificare le prime 4 righe della Sub fuzzy cosi' come le ho riportate.
Ciao