Fuzzy logic - sous VBA
Bonjour a tous
Je voudrais savoir comment utiliser fuzzyvlookup sous vba
Existe t il une fonction comme celle ci dessous ?
Application.Workfunction.FuzzyVLookup(ComboBox1, Range("Tableau2"), 1, 0.3, i)Par ce que actuellement je passe par excel.
Merci d'avance
bonjour,
as-tu essayé ainsi ?
Application.Worksheetfunction.FuzzyVLookup(ComboBox1, Range("Tableau2"), 1, 0.3, i)Bonjour,
Merci pour ta réponse.
J'ai essayé ce-ci pour essayer de le faire marcher.
Mais rien a faire il me dit " Propriété ou méthode non gérée par cette objet"
Sub fuzzy()
Dim C As Variant
Sheets("MEUDON").Select
Dim A As Variant
A = Sheets("MEUDON").Range("E10")
Dim B As Variant
B = Sheets("STOCK").Range("B11:B226")
C = Application.WorksheetFunction.FuzzyVLookup(A, B, 1, 0.3, 1)
Sheets("MEUDON").Range("I10") = C
End SubAprès en regardant dans le détail en faisaint juste C=FuzzyVLookup(
Il me dit : " Byval lookup value As string , Byval tablearray as range , byval Indexnum as integer, NFPpercent as single, Rang as integer"
Mon erreur doit venir de la .. -_-'
Merci d'avance
pas de réponse voici la fonction ..
Function FUZZYVLOOKUP(ByVal lookupvalue As String, _
ByVal tablearray As Range, _
ByVal IndexNum As Integer, _
Optional NFPercent As Single = 0.05, _
Optional Rank As Integer = 1, _
Optional Algorithm As Integer = 3, _
Optional AdditionalCols As Integer = 0) As Variant
'********************************************************************************
'** Function to Fuzzy match LookupValue with entries in **
'** column 1 of table specified by TableArray. **
'** TableArray must specify the top left cell of the range to be searched **
'** The function stops scanning the table when an empty cell in column 1 **
'** is found. **
'** For each entry in column 1 of the table, FuzzyPercent is called to match **
'** LookupValue with the Table entry. **
'** 'Rank' is an optional parameter which may take any value > 0 **
'** (default 1) and causes the function to return the 'nth' best **
'** match (where 'n' is defined by 'Rank' parameter) **
'** If the 'Rank' match percentage < NFPercent (Default 5%), #N/A is returned. **
'** IndexNum is the column number of the entry in TableArray required to be **
'** returned, as follows: **
'** If IndexNum > 0 and the 'Rank' percentage match is >= NFPercent **
'** (Default 5%) the column entry indicated by IndexNum is **
'** returned. **
'** if IndexNum = 0 and the 'Rank' percentage match is >= NFPercent **
'** (Default 5%) the offset row (starting at 1) is returned. **
'** This value can be used directly in the 'Index' function. **
'** **
'** Algorithm can take one of the following values: **
'** Algorithm = 1: **
'** This algorithm is best suited for matching mis-spellings. **
'** For each character in 'String1', a search is performed on 'String2'. **
'** The search is deemed successful if a character is found in 'String2' **
'** within 3 characters of the current position. **
'** A score is kept of matching characters which is returned as a **
'** percentage of the total possible score. **
'** Algorithm = 2: **
'** This algorithm is best suited for matching sentences, or **
'** 'firstname lastname' compared with 'lastname firstname' combinations **
'** A count of matching pairs, triplets, quadruplets etc. in 'String1' and **
'** 'String2' is returned as a percentage of the total possible. **
'** Algorithm = 3: Both Algorithms 1 and 2 are performed. **
'********************************************************************************
Dim R As Range
Dim strListString As String
Dim strWork As String
Dim sngMinPercent As Single
Dim sngWork As Single
Dim sngCurPercent As Single
Dim intBestMatchPtr As Integer
Dim intRankPtr As Integer
Dim intRankPtr1 As Integer
Dim i As Integer
Dim lEndRow As Long
Dim udRankData() As RankInfo
Dim vCurValue As Variant
'--------------------------------------------------------------
'-- Validation --
'--------------------------------------------------------------
lookupvalue = LCase$(Application.Trim(lookupvalue))
If IsMissing(NFPercent) Then
sngMinPercent = 0.05
Else
If (NFPercent <= 0) Or (NFPercent > 1) Then
FUZZYVLOOKUP = "*** 'NFPercent' must be a percentage > zero ***"
Exit Function
End If
sngMinPercent = NFPercent
End If
If Rank < 1 Then
FUZZYVLOOKUP = "*** 'Rank' must be an integer > 0 ***"
Exit Function
End If
ReDim udRankData(1 To Rank)
lEndRow = tablearray.Rows.Count
If VarType(tablearray.Cells(lEndRow, 1).Value) = vbEmpty Then
lEndRow = tablearray.Cells(lEndRow, 1).End(xlUp).Row
End If
'---------------
'-- Main loop --
'---------------
For Each R In Range(tablearray.Cells(1, 1), tablearray.Cells(lEndRow, 1))
vCurValue = ""
For i = 0 To AdditionalCols
vCurValue = vCurValue & R.Offset(0, i).text
Next i
If VarType(vCurValue) = vbString Then
strListString = LCase$(Application.Trim(vCurValue))
'------------------------------------------------
'-- Fuzzy match strings & get percentage match --
'------------------------------------------------
sngCurPercent = FuzzyPercent(String1:=lookupvalue, _
String2:=strListString, _
Algorithm:=Algorithm, _
Normalised:=True)
If sngCurPercent >= sngMinPercent Then
'---------------------------
'-- Store in ranked array --
'---------------------------
For intRankPtr = 1 To Rank
If sngCurPercent > udRankData(intRankPtr).Percentage Then
For intRankPtr1 = Rank To intRankPtr + 1 Step -1
With udRankData(intRankPtr1)
.Offset = udRankData(intRankPtr1 - 1).Offset
.Percentage = udRankData(intRankPtr1 - 1).Percentage
End With
Next intRankPtr1
With udRankData(intRankPtr)
.Offset = R.Row
.Percentage = sngCurPercent
End With
Exit For
End If
Next intRankPtr
End If
End If
Next R
If udRankData(Rank).Percentage < sngMinPercent Then
'--------------------------------------
'-- Return '#N/A' if below NFPercent --
'--------------------------------------
FUZZYVLOOKUP = CVErr(xlErrNA)
Else
intBestMatchPtr = udRankData(Rank).Offset - tablearray.Cells(1, 1).Row + 1
If IndexNum > 0 Then
'-----------------------------------
'-- Return column entry specified --
'-----------------------------------
FUZZYVLOOKUP = tablearray.Cells(intBestMatchPtr, IndexNum)
Else
'-----------------------
'-- Return offset row --
'-----------------------
FUZZYVLOOKUP = intBestMatchPtr
End If
End If
End FunctionL'idée c'est d'appeler cette fonction afin de réaliser un combox en fonction du rang 1,2,3,4,5
Merci d'avance
rebonjour,
essaie ceci
Sub fuzzy()
Dim C As Variant
Sheets("MEUDON").Select
Dim A As Variant
A = Sheets("MEUDON").Range("E10")
Dim B
set B = Sheets("STOCK").Range("B11:B226")
'C = Application.WorksheetFunction.FuzzyVLookup(A, B, 1, 0.3, 1)
'ceci devrait fonctionner aussi
C = FuzzyVLookup(A, B, 1, 0.3, 1)
Sheets("MEUDON").Range("I10") = C
End SubSalut
Merci beaucoup
Si je veux complexifier un peu la chose ...
Private Sub ComboBox1_change()
' au changement dans la ComboBox1
Dim A As Variant
Dim B As Variant
A = ActiveSheet.Name
B = ActiveSheet.Name & " - STOCK"
Sheets(A).Select
Dim C As Variant
Dim D As Variant
C = Sheets(A).Range("E10")
Set D = Range("Tableau2")
Sheets(A).Select
Rows("10:10").Select
ActiveCell.Offset(0, 4).Value = UserForm1.ComboBox1.Value
Dim Recherche(1 To 10) As String
'Création d un tableau des noms de Recherche
Dim i As Integer
For i = 1 To 10
Recherche(i) = FUZZYVLOOKUP(C, D, 1, 0.3, i)
ComboBox1.AddItem Recherche(i)
Next i
End SubProblème "incompatibilité de type "
Si tu aurais la réponse ?
Merci
bonsoir,
Problème "incompatibilité de type "
Si tu avais la réponse ?
sur quelle instruction as-tu ce message d'erreur.
si c'est sur cette ligne-ci
Recherche(i) = FUZZYVLOOKUP(C, D, 1, 0.3, i)quelle est la valeur de i au moment de l'erreur ?
Bonjour
Effectivement sur cette instruction pour i = 1
Dès que je tape la première lettre dans le combobox.
Merci
PoUlMoUtH a écrit :Bonjour
Effectivement sur cette instruction pour i = 1
Dès que je tape la première lettre dans le combobox.
Merci
es-tu sûr qu'il y a une réponse ? ne reçois-tu pas #N/A quand tu exécutes cette fonction hors VBA ?
sinon mets un fichier qui illustre ton problème.
PoUlMoUtH a écrit :Bonjour
Effectivement sur cette instruction pour i = 1
Dès que je tape la première lettre dans le combobox.
Merci
es-tu sûr qu'il y a une réponse ? ne reçois-tu pas #N/A quand tu exécutes cette fonction hors VBA ?
sinon mets un fichier qui illustre ton problème.
Ci joint le fameux fichier en question après une coupe maxi afin de le transférer .. 8)
Non la fonction fonctionne bien quand la cellule recherchée correspond a une valeur dans le stock ex "bannche de 2.5mmm" ( erreur faite exprès ) et j’exécute la fonction fuzzyvlookup dans le stock il me la retrouve et corrige.
Oui effectivement l'erreur doit venir du fait que quand je tape la première lettre => #N/A doit ressortir mais ça dépasse mes compétences ..
Encore merci
bonsoir,
quelle séquence d'opérations fais-tu pour obtenir l'erreur ?
Bonjour,
Dans l'onglet MEUDON j'ouvre le bouton GROS MATÉRIEL ( userform1 )
Tape les différents éléments dans les textboxs ( quantité date et autre ) et dès que je tape dans le ComboBox1 cela pose problème.
Auparavant la fonction Fuzzyvlookup été traité de manière simple dans le boutonclick4
Private Sub ComboBox1_change()
' au changement dans la ComboBox1
Dim A As Variant
Dim B As Variant
A = ActiveSheet.Name
B = ActiveSheet.Name & " - STOCK"
Sheets(A).Select
Dim C As Variant
Dim D As Variant
C = Sheets(A).Range("E10")
Set D = Range("Tableau2")
Sheets(A).Select
Rows("10:10").Select
ActiveCell.Offset(0, 4).Value = UserForm1.ComboBox1.Value
Dim Recherche(1 To 10) As String
'Création d un tableau des noms de Recherche
Dim i As Integer
For i = 1 To 10
Recherche(i) = FUZZYVLOOKUP(C, D, 1, 0.3, i)
ComboBox1.AddItem Recherche(i)
Next i
End SubJe ne suis pas sur d'avoir répondu a ta question ?
Merci
Bonjour,
je ne parviens pas à faire fonctionner ton code chez moi, librairies manquantes. mais je me demande si
la variable C n' est pas vide lorsque tu appelles la fonction et que la fonction te renvoie une erreur que tu ne gères pas.
C = Sheets(A).Range("E10")Bonjour
si, elle est vide. je voudrais qu'elle se remplisse au fur et a mesure que l'on écrit.
Mais si j'écris quelque chose auparavant dans C, je peux ensuite écrire une lettre et C est bien égal a la première lettre tapée ensuite viens le bug incompatibilité de type.
Ex : moteur de recherche Google ( il donne des propositions )
C'est possible ça ?
Merci
Rebonjour,
A tout hasard, le fichier ne fonctionne pas car il te manque peut être add-in fuzzy lookup pour excel ?
Il est disponible sur le site de Microsoft.
http://www.microsoft.com/en-us/download/details.aspx?id=15011
re-bonsoir,
je me suis mal fait comprendre je pense. Amon avis tu ne me peux pas appeler la fonction avec une valeur nulle.
déplace ton instruction C = Sheets(A).Range("E10") après y avoir mis la valeur introduite dans le combobox1
voir ci-dessous une proposition de correction à tester.
Private Sub ComboBox1_change()
' au changement dans la ComboBox1
Dim A As Variant
Dim B As Variant
A = ActiveSheet.Name
B = ActiveSheet.Name & " - STOCK"
Sheets(A).Select
Dim C As Variant
Dim D As Variant
'C = Sheets(A).Range("E10")
Set D = Range("Tableau2")
Sheets(A).Select
Rows("10:10").Select
ActiveCell.Offset(0, 4).Value = UserForm1.ComboBox1.Value
C = Sheets(A).Range("E10")
Dim Recherche(1 To 10) As String
'Création d un tableau des noms de Recherche
Dim i As Integer
For i = 1 To 10
Recherche(i) = FUZZYVLOOKUP(C, D, 1, 0.3, i)
ComboBox1.AddItem Recherche(i)
Next i
End SubBonjour,
ca change rien ..
Si je modifie un peu le principe, le calcul de fuzzy vlookup se fait que si je clic sur le combobox ça serait plus facile ? nn ?
J'ai fais comme ci dessous mais quand je clic sur combobox il ne se passe rien ..
je sais pas si c'est faisable ?
Private Sub ComboBox1_Change()
Dim A As Variant
A = ActiveSheet.Name
Sheets(A).Select
Rows("10:10").Select
ActiveCell.Offset(0, 4).Value = UserForm1.ComboBox1.Value
End SubPrivate Sub ComboBox1_Click()
Dim A As Variant
Dim B As Variant
A = ActiveSheet.Name
B = ActiveSheet.Name & " - STOCK"
Sheets(A).Select
Dim C As Variant
Dim D As Variant
'C = Sheets(A).Range("E10")
Set D = Range("Tableau2")
Dim Recherche(1 To 10) As String
Sheets(A).Select
Rows("10:10").Select
C = ActiveCell.Offset(0, 4).Value
'Création d un tableau des noms de Recherche
Dim i As Integer
For i = 1 To 10
Recherche(i) = FUZZYVLOOKUP(C, D, 1, 0.3, i)
ComboBox1.AddItem Recherche(i)
Next i
End Submerci d'avance
bonjour,
il ne se passe rien ou tu as un message d'erreur ?
non il ne se passe rien.
L'onglet est vide quand je clic dessus, pour moi il lance pas le code.
Et en marquant n'importe quoi pas de débogage ..
bonsoir,
pour vérifier si le code est lancé et fonctionne, peux-tu essayer ce code modifier.
la macro devrait s'arrêter sur l'instruction stop, fait ensuite F5 pour continuer ou F8 pour faire du pas à pas. j'ai forcé C à la valeur "BAN" pour le test.
Private Sub ComboBox1_Click()
Dim A As Variant
Dim B As Variant
A = ActiveSheet.Name
B = ActiveSheet.Name & " - STOCK"
Sheets(A).Select
Dim C As Variant
Dim D As Variant
'C = Sheets(A).Range("E10")
Set D = Range("Tableau2")
Dim Recherche(1 To 10) As String
Sheets(A).Select
Rows("10:10").Select
C = ActiveCell.Offset(0, 4).Value
'Création d un tableau des noms de Recherche
STOP
C="BAN"
Dim i As Integer
For i = 1 To 10
Recherche(i) = FUZZYVLOOKUP(C, D, 1, 0.3, i)
ComboBox1.AddItem Recherche(i)
Next i
End Sub