Rechercher texte et selectionner la cellule

**goninph** · 22/01/2017, 09h06

Bonjour à tous,

En 2016, Jacques Boisgontier, m'avais créer le code pour lister, rechercher et sélectionner des étiquettes, encore merci

Comment modifier le code pour faire la même chose, mais en listant le texte contenu dans les cellules et sélectionner la cellule contenant le texte

Voir fichier joint

Encore merci pour votre précieuse collaboration et bon dimanche

Philippe

**QuestVba** · 22/01/2017, 11h37

Bonjour,

Tu lui envoies un MP.

Plus sérieusement, comme je n'ouvre pas le fichier, ce serait bien que tu expliques exactement comment sont ficelées tes données, ... ?

NB : comme tu parles d'un code, peut-être aurais-tu plus de réponses sur la partie VBA.

**goninph** · 22/01/2017, 11h55

Envoyé par QuestVba

Bonjour,

Tu lui envoies un MP.

Plus sérieusement, comme je n'ouvre pas le fichier, ce serait bien que tu expliques exactement comment sont ficelées tes données, ... ?

NB : comme tu parles d'un code, peut-être aurais-tu plus de réponses sur la partie VBA.

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
Sub Recherche_Etiquettes()
 
On Error GoTo TropDeTexteDansEtiquette
 
    RechercheEtiquettes.Renommer_Etiquettes
    Search_Etiquettes.Show 'Si beug, vérifier le nombre de caratères par étiquette
 
Exit Sub
TropDeTexteDansEtiquette:
    MsgBox _
            "Dans une ou plusieurs étiquettes, le nombre" _
            & vbCrLf & _
            "maximum de 226 caractères est dépassé" _
            & vbCrLf & vbCrLf & _
            "       Diminuer le nombre de caractères" _
            & vbCrLf & vbCrLf & vbCrLf & _
            "                        !!! ATTENTION !!! " _
            & vbCrLf & vbCrLf & _
            "A 226 caractères la recherhe ne fonctionne plus" _
            , vbExclamation, "! Oups !"
 
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

et

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
Dim f, choix(), Rng, Ncol
 
'Début Userform =========================================================================================================================================================
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), " -  ") 'Remplace les retour ligne ou ENTER par un caractère
      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)
 
    BoutonToday.Caption = Now() 'Affiche la date du jour sur le BoutonToday
 
          Me.TextBox1.SetFocus 'Place le curseur dans la textbox
End Sub
'Recherche multicritéres séparé par un espace
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
'Au clique sélectionne l'étiquette trouvée
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 'Déplace le document pour rendre visible l'étiquette
    Range(adr).Select 'Déplace le document pour rendre visible l'étiquette
    f.Shapes(Trim(Me.ListBox1)).Select
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
'Rechercher la date aujourd'hui et déplacer au centre de l'écran
Private Sub BoutonToday_Click()
 
    With Worksheets("Planning")
        .Activate
        .Rows(4).Find(Date).Select
    End With
    Unload Me
End Sub
'Fin Userform =========================================================================================================================================================

Nom : cherche.png
Affichages : 489
Taille : 78,4 Ko

**boisgontierjacques** · 22/01/2017, 17h29

Bonjour,

Utiliser CTRL+F

Boisgontier
http://boisgontierjacques.free.fr

**goninph** · 22/01/2017, 17h36

Bonjour,

C'est ce que j'ai fait, mais j'aimerai avoir le même principe que la recherche d'étiquette qui est beaucoup plus rapide que CTRL+F

Vous pensez que c'est réalisable ?¨

Merci A+ Philippe

**boisgontierjacques** · 22/01/2017, 19h11

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
61
 
Dim f, choix(), Rng, Ncol
 
'Début Userform =========================================================================================================================================================
Private Sub UserForm_Initialize()
   Set f = ActiveSheet
   Set Rng = Range("A5:IV10000")
   Dim TblTmp()
   n = 0
   For Each c In Rng.SpecialCells(xlCellTypeConstants, 23)
      n = n + 1
      ReDim Preserve TblTmp(1 To 2, 1 To n)
      TblTmp(1, n) = c.Address
      On Error Resume Next
      tmp = Replace(Replace(c.Value, 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)
   Next c
   Ncol = 2
   Me.ListBox1.List = Application.Transpose(TblTmp)
   BoutonToday.Caption = Now() 'Affiche la date du jour sur le BoutonToday
   Me.TextBox1.SetFocus 'Place le curseur dans la textbox
End Sub
'Recherche multicritéres séparé par un espace
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
'Au clique sélectionne l'étiquette trouvée
Private Sub ListBox1_Click()
    For k = 0 To Ncol - 1
      Me("TextBox" & k + 2) = Me.ListBox1.Column(k)
    Next k
    adr = Me.ListBox1 'Déplace le document pour rendre visible l'étiquette
    Range(adr).Select 'Déplace le document pour rendre visible l'étiquette
End Sub

Boisgontier

**goninph** · 22/01/2017, 21h03

MAGIQUE

et Merci

Une question, comment rechecher la date dans une colonne au lieu d'une ligne

Fonctionne pour une date contenue dans la ligne 4

Code :

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

1
2
3
4
5
6
7
8
Private Sub BoutonToday_Click()
 
    With Worksheets("Planning")
        .Activate
        .Rows(4).Find(Date).Select
    End With
    Unload Me
End Sub

Ne fonctionne pas pour une date contenue dans la colonne A

Code :

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

1
2
3
4
5
6
7
8
Private Sub BoutonToday_Click()
 
    With Worksheets("Planning")
        .Activate
        .Column (A).Find(Date).Select
    End With
    Unload Me
End Sub

**unparia** · 22/01/2017, 21h10

Bonjour
Le minimum aurait été non de dire "ça ne fonctionne pas", mais "j'ai un message d'erreur variable non définie"
Déjà (et entre autres) : L'objet Column (A) n'existe pas
Existent, à ton choix : Columns("A") ou Columns(1)

**goninph** · 22/01/2017, 21h15

Oups, c'est pas faux

Merciiiiiiii j'avais déjà tout essayé tes propositions avant de poster, mais ça ne fonctionnait pas ...... forcément en oubliant le S à Column !!!!!!

Bonne soirée

**goninph** · 22/01/2017, 21h23

Hello Jacques,

La ListBox1 beug au clique lorsqu'il n'y a qu'un seul résultat,

l'adresse de la cellule n'est pas sur la même ligne, étrange ....

Autrement tout fonctionne à merveille encore merci

Nom : 22-01-2017 21-21-15.png
Affichages : 459
Taille : 12,9 Ko

Nom : 22-01-2017 21-21-15.png
Affichages : 459
Taille : 12,9 Ko

**boisgontierjacques** · 23/01/2017, 10h02

Bonjour,

Je n'observe pas ce bug chez moi

http://boisgontierjacques.free.fr/fi...teIntuitif.xls

Boisgontier

**unparia** · 23/01/2017, 11h36

Bonjour
Le message d'erreur rapporté ne peut arriver que si k > 9 (et que, donc : nbcol > 10), puisqu'une listbox ne peut comporter que 10 colonnes au maximum, numérotées de 0 à 9

**boisgontierjacques** · 23/01/2017, 13h05

>Le message d'erreur rapporté ne peut arriver que si k > 9 (et que, donc : nbcol > 10), puisqu'une listbox ne peut comporter que 10 colonnes au maximum, numérotées de 0 à 9

Un listBox peut avoir + de 10 colonnes (il suffit de l'alimenter avec List).

Exemple

http://boisgontierjacques.free.fr/fi...tiColonnes.xls

Boisgontier

**unparia** · 23/01/2017, 13h36

Bonjpur boisgontierjacques
je distingue personnellement toujours la "faisabilité" de la "possibilité d'exploitation".
On peut (assez curieusement) toujours dépasser certaines limites (VB est assez "tolérant" dans ce domaine) :
--- limite du nombre de lignes d'une listbox (en principe celle d'un type integer)
--- limite du nombre de colonnes d'une listbox (en principe 10)
Une autre affaire est de :
-- se référer à un index de ligne au-delà de la limite autorisée
-- se référer à une colonne au-delà de la limite autorisée

Fais ce petit test :

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
Private Sub CommandButton1_Click()
  ListBox1.Clear
  ListBox1.ColumnCount = 1
  ListBox1.AddItem "a"
  ' et maintenant : en dépit de ce que l'on ait qu'une seule colonne, VBAQ ne "bronchera même pas"
  ListBox1.List(0, 1) = "b"
  ListBox1.List(0, 2) = "c"
End Sub
 
 
 
Private Sub ListBox1_Click()
 ' et vba ne "brochera toujours pas"
 k = 4 ' alors même que nous n'avons que 1 colonne réelle et 3 colonnes "supposées"
  MsgBox ListBox1.Column(0) & "   " & ListBox1.Column(k)
  ' mais si nous "refilons" un n° de colonne > 9, là, il se "réveillera" et "bronchera" car cela échappe à ce qu'il peut "contrôler" et "gérer"
 k = 10
 MsgBox ListBox1.Column(0) & "   " & ListBox1.Column(k)
End Sub

Tu vas prendre ainsi toute la mesure de la permissivité abusive (trompeuse) de VBA.
Amitiés

**unparia** · 23/01/2017, 18h06

Hé non . C'est TOI, qui as raison.
Je viens de faire le test suivant, sans message d'erreur :

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
Private Sub CommandButton1_Click()
ListBox1.Clear
Dim toto(1 To 3, 1 To 12)
For i = 1 To 3
  For j = 1 To 12
    toto(i, j) = i & j
  Next
Next
ListBox1.List = toto
 
End Sub
 
Private Sub ListBox1_Click()
For k = 0 To 11
  MsgBox k & " ===> " & ListBox1.Column(k)
Next
End Sub

Contre toute logique ...

**goninph** · 23/01/2017, 18h57

Hello,

Toutes vos propositions beug, seulement si il n'y a qu'un seul résultat et l'adresse de la cellule n'est pas sur la même ligne, étrange ....

Si il y a 2 résultats ou plus dans la liste, tout fonctionne

A+ Philippe

**boisgontierjacques** · 23/01/2017, 19h42

Difficile de tester sans programme:

-Remplacer le On Error par Me.TextBox1 = Ltrim(Me.TextBox1)
-Supprimer le UserForm_Initialize après le Else

Boisgontier

**goninph** · 28/01/2017, 10h05

Hello,

Les modification empêche la saisie d'un espace, c'est parfait, mais le problème reste avec une seule ligne ....

Qu'entendez-vous par Difficile de tester sans programme ?

Merci et bon week end

Philippe

Rechercher texte et selectionner la cellule

Excel

Discussions similaires

Partager

Partager