Recherche VBA d'un contenu de cellule

alcalzone

XLDnaute Occasionnel
Bonjour à tous et toutes,

Je bute sur ce code qui me sert à afficher via un filtre automatique le contenu d'un textbox.
Je voudrai que le filtre m'affiche les données même si le contenu de ma textbox n'est qu'une partie des cellules de ma colonne désignation. Je n'arrive pas à placer le "*" en automatique dans le code.
J'espère avoir été clair dans mon explication.
Merci de votre aide

If desi <> "" Then 'desi =nom de ma textbox
des = desi.Value 'des est le nom de ma colonne où sont stockées mes désignations dans la feuil stock

critere = critere & "(stock!f2=""" & des & """)* "
Sheets("Cachée").Range("f5") = des ' cachée est ma feuille où les données du filtre auto se déversent


critere = "=" & critere & "1"
Sheets("Cachée").Range("A2").Value = critere

Sheets("stock").Range("stock!A1:eek:5000").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("cachée!A1:A2"), CopyToRange:=Range("cachée!A4:eek:4"), Unique:= _
False
Unload Me
Usfconsul.Show
 

MichD

XLDnaute Impliqué
Re : Recherche VBA d'un contenu de cellule

Bonjour,

Voici un exemple : Recherche l'expression "mo" dans la plage A1:A10 peu importe où l'expression est placée dans la cellule.
Le résultat est copié dans une autre feuille avec l'étiquette de colonne et sans étiquette de colonne.
Si ta feuille est masquée, l'exécution de ce code ne demande pas de démasquer la feuille.



'---------------------------------------------------
VB:
Sub test()
Dim Expression As String
Expression = "mo"  ' ou Userform1.TextBox1.Value
With Feuil3 ' Worksheets("Feuil3")
    With .Range("A1:A10")
        .AutoFilter field:=1, Criteria1:="*" & Expression & "*"
        'Copie l'étiquette de colonne + les données filtrées
        .SpecialCells(xlCellTypeVisible).Copy _
                    Worksheets("Feuil2").Range("A1")
        'Pour copier seulement les données sans l'étiquette de colonne
        .Offset(1).Resize(.Rows.Count - 1). _
            SpecialCells(xlCellTypeVisible).Copy _
                Worksheets("Feuil2").Range("A1")
        'enlève le filtre
        .AutoFilter
    End With
End With
End Sub
'---------------------------------------------------
 
Dernière édition:

alcalzone

XLDnaute Occasionnel
Re : Recherche VBA d'un contenu de cellule

Bonjour MichD,
Merci pour ta réponse.
Ca fonctionne très bien à condition que le contenu de la cellule recherché se trouve dans la colonne A et soit au format text.
Moi, les données où doit se faire la recherche est en G avec des données en A au format nombre.
Je joints un bout de fichier pour exemple.
 

Pièces jointes

  • Classeur1.xls
    29 KB · Affichages: 74
  • Classeur1.xls
    29 KB · Affichages: 81
  • Classeur1.xls
    29 KB · Affichages: 81

MichD

XLDnaute Impliqué
Re : Recherche VBA d'un contenu de cellule

La recherche se fait dans toute la feuille, peu importe la colonne où se retrouve l'expression. La procédure recopie la ligne des données de la feuille où l'expression a été trouvée vers une autre feuille à la suite des données existantes.


VB:
Option Compare Text
'----------------------------------
Sub test()
Dim Expression As String, DerLig As Long
Dim Rg As Range, DerCol As Integer
Dim Ligne As Long, Trouve As Range, C As Range

'Selon la manière dont tu définis l'expression
'à rechercher le résultat va différer.
'Peut être : "ose", " ose", "ose ", " ose "
Expression = "ose"

With Feuil3 ' Worksheets("Feuil3")
    If Not IsEmpty(.UsedRange) Then
        DerLig = .Cells.Find(What:="*", _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row

        DerCol = .Cells.Find(What:="*", _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious).Column
                
        Set Rg = .Range("A1", .Cells(DerLig, DerCol))
    End If
End With

For Each C In Rg.Rows
    With C
        Set Trouve = .Find(What:=Expression, _
                LookIn:=xlValues, lookat:=xlPart, _
                SearchOrder:=xlByRows)

        If Not Trouve Is Nothing Then
            'Copie vers la feuille Feuil2
            With Feuil2
                DerLig = .Cells.Find(What:="*", _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious).Row + 1
                Trouve.EntireRow.Copy .Range("A" & DerLig)
            End With
        End If
    End With
Next
'----------------------------------
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
312 382
Messages
2 087 838
Membres
103 667
dernier inscrit
datengo