Recherche d'element similaire dans une BD

Résolu
JSCH19 Messages postés 129 Date d'inscription mercredi 30 octobre 2019 Statut Membre Dernière intervention 22 juin 2023 - 2 juin 2023 à 07:49
yg_be Messages postés 22732 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 28 avril 2024 - 2 juin 2023 à 20:53

Bonjour,comment allez-vous?

mon soucis est d'effectuer une recherche dans une base de donnée a partir d'un textbox dans un userform. Ce que je veux c'est que le code determine la dimension (len ou nbcar) identifié par "x=len(code)" du texte du textbox identifié par "Code=me.textbox1" et aille chercher dans la premiere cellule identifier par "cible=sheet1.Range("C7")" du tableau,colonne "C"  si la dimension de la valeur de la premiere cellule "y=len(cible)" est egale a la dimension du texte du textbox "x".

-Si celle-ci (la dimension du texte du textbox) "x" est superieur a la dimension de la valeur de la premiere cellule "y"(alors on retire  (-1) a x  jusqu'a ce que x et y soient egaux ,une fois les dimensions sont egales ont determine la nouvelle valeur de code par z=left(code,x) puis on compare si z est egale a cible,si oui le loop s'arrete si non le loop continue d'effectuer le meme processus pour les autres cellules de la colonne "C" pour trouver quelle valeur du tableau est egale a la valeur du textbox "code" sachant qu'a chaque fois qu'on compare la valeur du textbox "code" d'une valeur du tableau on doit mettre a egalite la dimension de x et y puis donner z la nouvelle valeur de "code" en prenant "x" en compte.

Dim cible As Range, code As String, x As Long, y As Long, z As String
Dim ws As Worksheet

On Error Resume Next

Set ws = Sheet1

With ws

Set cible = .Range("C7")
code = Me.TextBox1
x = Len(code)
y = Len(cible)

Do While cible <> Empty 'agir pendant que cible n'est pas vide
If x = y Then'si x est superieur a y
If cible = code Then
Me.Resultat.Caption = cible
End If

ElseIf x > y Then 'si x est superieur a y.
Do Until x = y 'agir jusqu'a ce que x aie la meme dimension que y
x = x - 1 'diminuer x jusqu'a ce que x soit egale a y
Loop
z = Left(code, x) 
End If

If z = cible Then ' si z egale a cible Me.Resultat.Caption est egale a z
Me.Resultat.Caption = z
Exit Do 'terminer le loop
Else
End If
Set cible = cible.Offset(1)
Loop


 

A voir également:

3 réponses

JSCH19 Messages postés 129 Date d'inscription mercredi 30 octobre 2019 Statut Membre Dernière intervention 22 juin 2023
2 juin 2023 à 07:56
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702
2 juin 2023 à 09:20

Bonjour,

Comprends pas trop le but du jeux!

Expliquez ce que vous attendez en finalite?

0
JSCH19 Messages postés 129 Date d'inscription mercredi 30 octobre 2019 Statut Membre Dernière intervention 22 juin 2023
2 juin 2023 à 17:09

Bonjour,

ce que je veux que le code execute,c est de trouver le prefixe du text du textbox et que ce préfixe existe dans la colonne “C” du tableau

Exemple: le tableau a 4 colonnes 

Id,prefixe,longueur,code

imagine que j’inscrive ARG4000 dans le textbox je veux que le code commence par la première cellule du tableau qui est “C7” où “C7” = 98 puis vérifie si la dimension de “ARG4000” qui est 7 et la dimension de “C7” qui est 2 alors il dira si 7 supérieur a 2 diminuons 7 jusqu’à ce qu’il soit egale a 2 puis une fois égale il déterminera z=left(“ARG4000”,2) donc z aura pour valeur “AR” et ira comparer z avec la valeur de la cellule “C7” 
if AR=98 then  dire oui mais si non continuer le meme processus pour chaque cellule du tableau pour trouver si le mot inscris au textbox a son prefixe au tableau colonne “C”

0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702
2 juin 2023 à 18:31

Re,

Si j'ai bien compris

textbox =ARG4000 recherche dans Colonne C si il y a un prefixe qui serait inclu dans le texte ARG4000 ex: ARG40

Plutot que de faire des boucles sur la longueur, un simple test like fera l'affaire

0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702
2 juin 2023 à 18:35

Suite:

Sub LoadTextbox()
    Dim code As String
    Dim ws As Worksheet
    
    'On Error Resume Next
    If Me.TextBox1 <> "" Then
        Set ws = Sheet1
        code = Me.TextBox1
        With ws
            Derlig = .Range("B" & .Rows.Count).End(xlUp).Row
            Set Plage = .Range("B7:B" & Derlig)
            For Each Cel In Plage
                If code Like Cel & "*" Then
                    Me.Resultat.Caption = Cel
                    Exit For
                End If
            Next
        End With
    End If
End Sub
0
JSCH19 Messages postés 129 Date d'inscription mercredi 30 octobre 2019 Statut Membre Dernière intervention 22 juin 2023 > f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024
2 juin 2023 à 18:37

Je vais tester le code.

0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702 > f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024
2 juin 2023 à 18:38

Suite: code plus complet

Sub LoadTextbox()
    Dim code As String
    Dim ws As Worksheet
    Dim Plage As Range
    Dim cel As Range
    
    'On Error Resume Next
    If Me.TextBox1 <> "" Then
        Set ws = Sheet1
        code = Me.TextBox1
        With ws
            Set Plage = .Range("B7:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
            For Each cel In Plage
                If code Like cel & "*" Then
                    Me.Resultat.Caption = cel
                    Exit For
                End If
            Next
        End With
    End If
    Set ws = Nothing
    Set Plahe = Nothing
End Sub
0
JSCH19 Messages postés 129 Date d'inscription mercredi 30 octobre 2019 Statut Membre Dernière intervention 22 juin 2023 > f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024
2 juin 2023 à 20:01

Merci infiniment c est la première fois que j utilise la fonction #like et ca marche à merveille 

0
yg_be Messages postés 22732 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 28 avril 2024 1 477 > JSCH19 Messages postés 129 Date d'inscription mercredi 30 octobre 2019 Statut Membre Dernière intervention 22 juin 2023
2 juin 2023 à 20:53

bonjour,

peux-tu alors marquer la discussion comme résolue?

0