Discussion :

[goninph]

Bonjour,

J'ai un planning avec une centaine de zone de texte contenant, du texte minuscule, majuscule et des chiffres

Plusieurs étiquettes contiennent presque le même texte

J'aimerai effectuer une recherche avec plusieurs occurrences séparées par un espace (multirecherche) et non sensible à la casse

Si plusieurs étiquettes contiennent les mêmes occurrences, elles devraient être listées dans une ListBox et au clique sur la ligne désirée sélectionner l'étiquette du planning et ainsi de suite

Voici du code que j'ai trouvé sur le NET et une image de l'Userform désiré avec le code déjà transmis par Monsieur Jacques Boisgontier pour un autre projet avec la fonction multirecherche

Comment faire pour mixer les deux ?

Merci pour votre aide et bonne soirée

Philippe

L'image de l'UserForm multirecherche désiré


Le code du NET :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub recherchecontenuzone()
Dim laShape As Shape, celluleCentre As Range, centreT As Double, centreL As Double, i As Long
Dim nbColAffichees As Long, nbLigAffichees As Long, decalageCol As Long, decalageLig As Long
Dim numOf As String, laFeuille As Worksheet, trouve As Boolean
 
    'récupérer le numéro d'OF à rechercher
  numOf = InputBox("Numéro d'OF à rechercher :", "Rechercher")
 
    trouve = False
    'boucler sur chaque feuille du classeur
   For Each laFeuille In ThisWorkbook.Sheets
    'boucler sur toutes les formes de la feuille
   For Each laShape In laFeuille.Shapes
    If laShape.Name Like "Text Box *" Then
    If laShape.TextFrame.Characters.Text Like "*" & numOf & "*" Then trouve = True
    If trouve Then Exit For
    End If
    Next laShape
    If trouve Then Exit For
    Next laFeuille
 
    'si aucune forme contenant le numéro d'of n'a été trouvée, quitter la macro
  If laShape Is Nothing Then
                                MsgBox "Non trouvé"
                                Exit Sub
    End If
 
    'activer la feuille et sélectionner la forme
  laFeuille.Activate
    laShape.Select
 
    'centrer la forme à l'écran
  'calculer les "coordonnées" du centre de la forme
  centreT = laShape.Top + laShape.Height / 2
    centreL = laShape.Left + laShape.Width / 2
 
    'calculer la cellule correspondante aux "coordonnées"
  Set celluleCentre = Sheets(1).Range("A1")
 
    While celluleCentre.Offset(0, 1).Left < centreL
        Set celluleCentre = celluleCentre.Offset(0, 1)
    Wend
    While celluleCentre.Offset(1, 0).Top < centreT
        Set celluleCentre = celluleCentre.Offset(1, 0)
    Wend
 
    'vériffier le nombre de lignes et colonnes affichées
  nbColAffichees = ActiveWindow.VisibleRange.Columns.Count
    nbLigAffichees = ActiveWindow.VisibleRange.Rows.Count
 
    'calculer la cellule (colonne et ligne) à afficher en haut à droite
  decalageCol = IIf(celluleCentre.Column - CInt(nbColAffichees / 2) + 1 < 1, 1, celluleCentre.Column - CInt(nbColAffichees / 2) + 1)
    decalageLig = IIf(celluleCentre.Row - CInt(nbLigAffichees / 2) + 1 < 1, 1, celluleCentre.Row - CInt(nbLigAffichees / 2) + 1)
 
    'positionner la fenêtre (bugge depuis VBE, la macro doit être lancée depuis le excel)
  ActiveWindow.ScrollColumn = decalageCol
    ActiveWindow.ScrollRow = decalageLig
End Sub

Le code de Monsieur Jacques Boisgontier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Dim F, choix()
 
Private Sub UserForm_Initialize()
'====================================================================================================
'Pour avoir toutes et que les lignes pleines dans la ListBox, sans plus, car la formule est considérées comme celule pleine
'Formule en colonne B =C1&" "&D1&" "&E1&" "&F1
    Dim Plage_cellules_pleines As Variant
    Dim Feuilles_de_départ As Variant
Application.ScreenUpdating = False ' Désactive le changement des pages à l'écran lors de l'éxécution de la macro
 
Feuilles_de_départ = ActiveSheet.Name
'Vider toutes les cellules de  colonne A
        Sheets("Data SAP").Select
            Columns("A:A").Select
                 Selection.ClearContents
 
 
        Plage_cellules_pleines = Application.CountA([C1:C65000]) 'Compte le nombre de cellules pleine dans la colonne C
            Range("B" & Plage_cellules_pleines).Select 'Selectionne la cellule B de la même ligne
                Range(Selection, Selection.End(xlUp)).Select 'Sélectionne la plage contre le haut
 
' Copie la plage et colle que les valeurs en colonne A et largeur de colonne automatique
        Selection.Copy
            Range("A1").Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                        Columns("A:A").EntireColumn.AutoFit
'====================================================================================================
 
Sheets(Feuilles_de_départ).Select
 
   Set F = Sheets("Data SAP")
      Set Rng = F.Range("A2:A" & F.[A65000].End(xlUp).Row) ' Sélectionne toutes les lignes non vide, pas de ligne vide à la fin du formulaire
 
   choix = Application.Transpose(Rng)
   Me.ListBox1.List = choix
 
     Me.TextBox1.SetFocus 'Place le curseur dans la textbox
 
Application.ScreenUpdating = True ' Résactive le changement des pages à l'écran lors de l'éxécution de la macro
 
End Sub
Private Sub TextBox1_Change()
   mots = Split(Trim(Me.TextBox1), " ") ' Permet une recherche multiple, taper les requêtes en séparant par un espace
   tbl = choix
   For i = LBound(mots) To UBound(mots)
     tbl = Filter(tbl, mots(i), True, vbTextCompare)
   Next i
   Me.ListBox1.List = tbl
End Sub
Private Sub ListBox1_Click()
  ActiveCell = Me.ListBox1 'Inscrit le texte dans la cellule active
  Unload Me
End Sub
 
'Pour fermer l'UserForm avec le bouton ESC, le CommandButton1 est caché au bas de l'UserForm
'La propriété Cancel du CommandButton1 doit être à TRUE
Private Sub CommandButton1_Click()
Unload Me
End Sub