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

[boisgontierjacques]

Bonjour,

cf PJ

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
 
Dim f, choix(), Rng, Ncol
Private Sub UserForm_Initialize()
   Set f = Sheets("BD")
   i = 1
   For Each s In ActiveSheet.Shapes
    If s.Type <> 8 And s.Type <> 13 Then
      i = i + 1
      Cells(i, 1) = s.Name
      Cells(i, 2) = s.TextFrame.Characters.Text
      'Cells(i, 3) = s.Type
    End If
   Next s
   Set Rng = f.Range("a2:B" & f.[a65000].End(xlUp).Row)
   TblTmp = Rng.Value
   Ncol = Rng.Columns.Count
   For i = LBound(TblTmp) To UBound(TblTmp)
     ReDim Preserve choix(1 To i)
     For k = LBound(TblTmp) To UBound(TblTmp, 2)
       choix(i) = choix(i) & TblTmp(i, k) & " * "
     Next k
   Next i
   Me.ListBox1.List = Rng.Value
End Sub
 
Private Sub TextBox1_Change()
   If Me.TextBox1 <> "" Then
     mots = Split(Trim(Me.TextBox1), " ")
     Tbl = choix
     For i = LBound(mots) To UBound(mots)
       Tbl = Filter(Tbl, mots(i), True, vbTextCompare)
     Next i
       n = 0: Dim b()
       For i = LBound(Tbl) To UBound(Tbl)
         a = Split(Tbl(i), "*")
         n = n + 1: ReDim Preserve b(1 To Ncol, 1 To n)
         For k = 1 To Ncol
           b(k, i + 1) = a(k - 1)
         Next k
       Next i
       If n > 0 Then
         ReDim Preserve b(1 To Ncol, 1 To n + 1)
         Me.ListBox1.List = Application.Transpose(b)
         Me.ListBox1.RemoveItem n
       End If
       Me.Label1.Caption = UBound(Tbl) + 1
   Else
    UserForm_Initialize
  End If
End Sub
 
Private Sub ListBox1_Click()
    For k = 0 To Ncol - 1
      Me("TextBox" & k + 2) = Me.ListBox1.Column(k)
    Next k
    f.Shapes(Trim(Me.ListBox1)).Select
End Sub

Boisgontier

[goninph]

Bonjour Monsieur Jacques Boisgontier,

IMPRESSIONNANT, mais comment faire pour sélectionner l'étiquette en cliquant sur la ligne de la List Box ?

Un autre point, les numéros des Text Box ont 4 digits 6151, et je viens de me rendre compte que toutes mes Text Box porte le même numéro 6151,ce qui ne doit pas être normal ?

Merci et meilleures salutations

Philippe

[boisgontierjacques]

comment faire pour sélectionner l'étiquette en cliquant sur la ligne de la List Box ?

Ajouter cette ligne dans la procédure ListBox1_Click()


f.Shapes(Trim(Me.ListBox1)).Select

Code :

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

1
2
3
4
5
6
7
 
Private Sub ListBox1_Click()
    For k = 0 To Ncol - 1
      Me("TextBox" & k + 2) = Me.ListBox1.Column(k)
    Next k
    f.Shapes(Trim(Me.ListBox1)).Select
End Sub

Renommer tous les shapes d'un onglet

Code :

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

1
2
3
4
5
6
7
8
9
10
 
Sub renommeShapes()
     i = 0
     For Each s In ActiveSheet.Shapes
      If s.Type <> 8 And s.Type <> 13 Then
        i = i + 1
        s.Name = "TextBox" & i
     End If
   Next s
End Sub

En PJ, une recherche multi-mots & multi-colonnes dans une BD

Boisgontier
http://boisgontierjacques.free.fr

[goninph]

Bonjour,

Je vais essayer.

La première macro plante sur mon fichier planning, mais pas tout de suite, au bout de 3 secondes, la macro me sort quelques étiquettes et m'invite à débeuger ...

Est il obligatoire de lister les étiquettes dans les colonnes de la feuille, je n'ai pas la place ?

En 2 mots, comment fonctionne cette ensemble de macro ?

Merci A+ Philippe

[boisgontierjacques]

Sur cette version, la lecture des étiquettes se fait directement dans des Arrays

Si le pgm plante sur cette instruction

TblTmp(2, n) = s.TextFrame.Characters.Text

Remplacer par

On Error Resume Next
TblTmp(2, n) = s.TextFrame.Characters.Text
On Error Goto 0

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
 
Private Sub UserForm_Initialize()
   Set f = Sheets("BD")
   Dim TblTmp()
   n = 0
   For Each s In ActiveSheet.Shapes
    If s.Type <> 8 And s.Type <> 13 Then
      n = n + 1
      ReDim Preserve TblTmp(1 To 2, 1 To n)
      TblTmp(1, n) = s.Name
      TblTmp(2, n) = s.TextFrame.Characters.Text
      ReDim Preserve choix(1 To n)
      choix(n) = choix(n) & TblTmp(1, n) & " * " & TblTmp(2, n)
    End If
   Next s
   Ncol = 2
   Me.ListBox1.List = Application.Transpose(TblTmp)
End Sub

Boisgontier

[goninph]

Bonjour,

Le fichier joint est exactement ce que je recherche, vous êtes un génie,
Si je déplace, le UserForm1 et le Module1 et que je renomme ma feuille BD et que je lance la macro, beug immédiat, voir image

Pis j'ai oublié, le renommage des étiquettes est d'une rapidité impressionnante, mille merci

Merci A+ Philippe

Erreur:



Après avoir modifié le code suivant :

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
Private Sub UserForm_Initialize()
   Set f = Sheets("BD")
   Dim TblTmp()
   n = 0
   For Each s In ActiveSheet.Shapes
    If s.Type <> 8 And s.Type <> 13 Then
      n = n + 1
      ReDim Preserve TblTmp(1 To 2, 1 To n)
      TblTmp(1, n) = s.Name
'      TblTmp(2, n) = s.TextFrame.Characters.Text
 
 
      On Error Resume Next
TblTmp(2, n) = s.TextFrame.Characters.Text
On Error GoTo 0
 
 
 
 
      ReDim Preserve choix(1 To n)
      choix(n) = choix(n) & TblTmp(1, n) & " * " & TblTmp(2, n)
    End If
   Next s
   Ncol = 2
   Me.ListBox1.List = Application.Transpose(TblTmp)
End Sub

Autre erreur :

[goninph]

Bonsoir,

Mille excuses tout fonctionne, le beug était dû à cette étiquette

Par contre, lorsque l'étiquette sélectionnée se trouve en dehors de l'écran je ne l'a voit pas. Serait il possible de faire bouger le document afin que l'étiquette trouvée se situe au centre ou dans la surface visible de l'écran ?

Petit beug, lorsque je commence par un espace, la fenêtre de débogage s'affiche

Merci mille fois, vous êtes le KING

Bonne soirée

Philippe

[boisgontierjacques]

Pour que l'étiquette soit visible

Code :

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

1
2
3
4
5
6
7
8
9
 
Private Sub ListBox1_Click()
    For k = 0 To Ncol - 1
      Me("TextBox" & k + 2) = Me.ListBox1.Column(k)
    Next k
    adr = f.Shapes(Trim(Me.ListBox1)).TopLeftCell.Address
    Range(adr).Select
    f.Shapes(Trim(Me.ListBox1)).Select
End Sub

Boisgontier

[goninph]

Bonsoir,

Magnifique et encore merci

Philippe

[boisgontierjacques]

Suppression des sauts de ligne


Boisgontier

[goninph]

Bonjour,

Une situation étrange, la fonction recherche fonctionne à merveille, mais le contenu de l'étiquette ne s'affiche pas totalement, mais le texte est trouvé (image avec les flèches rouge)

Seule la première ligne est affichée, mais dans d'autre étiquette tout le texte s'affiche avec le symbole retour ligne, comme la deuxième image

Dans les 2 cas la recherche fonctionne, juste le texte n'est pas affiché .... étrange

Pour info il y a 3 retour à la ligne dans chaque étiquette

Merci et bonne soirée

Philippe

[goninph]

Bonsoir,

Une merveille avec juste 5 petites modifications :

Mille Merci pour toute l'aide apportée

Bonne soirée Philippe

- j'ai remplacé Chr(11), ""), Chr(10), ""), par Chr(11), " - "), Chr(10), " - ")
- Ajout de la ligne Me.TextBox1.SetFocus 'Place le curseur dans la textbox
- Set f = ActiveSheet à la place de Set f = Sheets("BD") 'Améliore la polyvalence

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
Private Sub UserForm_Initialize()
   Set f = ActiveSheet
   Dim TblTmp()
   n = 0
   For Each s In ActiveSheet.Shapes
    If s.Type <> 8 And s.Type <> 13 Then
      n = n + 1
      ReDim Preserve TblTmp(1 To 2, 1 To n)
      TblTmp(1, n) = s.Name
      On Error Resume Next
      tmp = Replace(Replace(s.TextFrame.Characters.Text, Chr(11), " - "), Chr(10), " - ")
      On Error GoTo 0
      TblTmp(2, n) = tmp
      ReDim Preserve choix(1 To n)
      choix(n) = choix(n) & TblTmp(1, n) & " * " & TblTmp(2, n)
    End If
   Next s
   Ncol = 2
   Me.ListBox1.List = Application.Transpose(TblTmp)
 
          Me.TextBox1.SetFocus 'Place le curseur dans la textbox
 
End Sub

- Dans le UserForm ajout d'un CommandButton1 caché avec la propriété Cancel à TRUE pour fermer par la touche ESC

Code :

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

1
2
3
Private Sub CommandButton1_Click()
Unload Me
End Sub

- Ajouter la ligne On Error Resume Next pour éviter le beug lorsque l'on saisi un espace pour commencer

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
Private Sub TextBox1_Change()
 
On Error Resume Next 'Evite le beug lorsque l'on saisi un espace pour commencer
   If Me.TextBox1 <> "" Then
     mots = Split(Trim(Me.TextBox1), " ")
     Tbl = choix
     For I = LBound(mots) To UBound(mots)
       Tbl = Filter(Tbl, mots(I), True, vbTextCompare)
     Next I
       n = 0: Dim b()
       For I = LBound(Tbl) To UBound(Tbl)
         a = Split(Tbl(I), "*")
         n = n + 1: ReDim Preserve b(1 To Ncol, 1 To n)
         For k = 1 To Ncol
           b(k, I + 1) = a(k - 1)
         Next k
       Next I
       If n > 0 Then
         ReDim Preserve b(1 To Ncol, 1 To n + 1)
         Me.ListBox1.List = Application.Transpose(b)
         Me.ListBox1.RemoveItem n
       End If
       Me.Label1.Caption = UBound(Tbl) + 1
   Else
    UserForm_Initialize
  End If
 
End Sub

[goninph]

Une autre modification pour éviter que plusieurs étiquettes portent le même nom, lancer systématiquement le renommage des étiquettes à l'ouverture de l'UserForm

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
Sub OuvrirRecherche()
Lire_Etiquettes.Renommer_Etiquettes
  Search_Etiquettes.Show
End Sub
Sub LireTexteShapes()
  I = 1
  For Each s In ActiveSheet.Shapes
    I = I + 1
    Cells(I, 1) = s.Name
    Cells(I, 2) = TexteShape(s)
    Cells(I, 3) = s.Type
  Next s
End Sub
Function TexteShape(s)
  TexteShape = s.TextFrame.Characters.Text
End Function
 
Sub Renommer_Etiquettes()
     I = 0
     For Each s In ActiveSheet.Shapes
      If s.Type <> 8 And s.Type <> 13 Then
        I = I + 1
        s.Name = "E" & I
     End If
   Next s
End Sub

[boisgontierjacques]

Bonjour,


Mettre la propriété MultiLine de TextBox3 à True

Boisgontier

[goninph]

Bonjour,

Dans quel but ?

Merci

Philippe

[boisgontierjacques]

Si le TextBox n'est pas assez large pour le texte, il y a passage à la ligne automatiquement.

Boisgontier

[goninph]

Ok merci pour l'info et bonne soirée Philippe

[goninph]

Bonjour Monsieur Boisgontier,

Peut on filtrer et afficher seulement les étiquettes contenant des numéros, étiquettes pouvant contenir une suite de 4 numéros et plus ?

J'ai ajouté ce message d'erreur pour les raisons indiquées, car si une seule étiquette contient 226 caractères, le message d'erreur ne s'affiche pas et la recherche fonctionne bizarrement

Merci mille fois pour votre précieuse aide et excellente journée

Philippe