Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 rechercher un mot dans une base

dindin

XLDnaute Occasionnel
Bonjour le forum
j'ai 2 onglet :
- Base
- résultat
le premier contient les colonnes B à F
en A1 le mot à rechercher dans base (colonnes B à F)

cette base contient plus de 6200 lignes.

mon objectif si possible est le suivant :
chercher dans la colonne B (uniquement) le mot se trouvant en A2 de l'onglet base
- le colorier en bleu et le mettre ne gras (que le mot recherché)
- copier les lignes (colonne de A à F ) de répétition de ce mot dans les phrases
- Coller tout ça dans l'onglet Résultat et laisser la base inchangée pour une nouvelle recherche d'un nouveau mot.
chaque résultat d'un nouveau mot recherché sera copié coller à la suite du précédant mot dans l'onglet résultat
comme dans l'exemple du fichier joint
j’espère que mon explication était claire pour vous.

Merci d'avance pour votre aide
 

Pièces jointes

  • dindin- recherche mot.xlsm
    158.6 KB · Affichages: 20

patricktoulon

XLDnaute Barbatruc
bonjour dindin
quand je te dis que tes fichiers ont un problème regarde l'erreur imcompréhensible
j'ai vérifier et enlever l'espace dans le doute mais VBA ne trouve pas ton sheets "base"


non vraiment vérifie tes fichiers voir meme ton application excel parce que la c'est le foutoir vba plante partout
 
Dernière édition:

dindin

XLDnaute Occasionnel
Bonjour
Quelle forme si le mot existe dans plusieurs phrase et ou même dans la même phrase?

Bonjour
Merci
si le mot existe une ou plusieurs fois dans la même phrase , lors de copier coller dans l'onglet résultat il prend la couleur bleu et devient gras et la ligne entière sera coller
la base reste inchangé car j'ai besoin de rechercher d'autres mots
 

dindin

XLDnaute Occasionnel
Franchement désolé
sur mon ordi cela fonctionne très bien .
Je te joint un nouveau fichier fait de A à Z et non pas une copie
 

Pièces jointes

  • test recherche.xlsx
    12 KB · Affichages: 19

patricktoulon

XLDnaute Barbatruc
re
avec ton dernier fichier
regarde dans le debug
VB:
Sub test()
    Dim addr$, mot$, oldmot$, i&, c As Range, firstAddress$, punion As Range, cel As Range
    With Worksheets("Base")
        Set plage = .Range("b2:b" & .Cells(Rows.Count, "b").End(xlUp).Row)
        oldmot = .Cells(2, 1).Text
        .Cells(Rows.Count, 1).End(xlUp).Offset(1) = "xxxx" 'obligé d'ajouter sinon il prend pas la derniere va savoir pourquoi
        For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            If .Cells(i, "A").Text <> "" Then
                mot = .Cells(i, "A").Text
                If mot <> oldmot Then
                    If Not punion Is Nothing Then
                        If Not punion.Cells(1) Like "*" & oldmot & "*" Then Set punion = Range(Replace(punion.Address, punion.Cells(1).Address & ",", ""))
                        'nextrow = Sheets("résultat").Cells(Rows.Count, 2).End(xlUp).Offset(3).Row
                        'Sheets("résultat").Cells(nextrow, 1) = oldmot

                        'For Each area In punion.Areas
                            'For Each cel In area.Cells
                                'nextrow = Sheets("résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
                                'Sheets("résultat").Cells(nextrow, 2) = cel.Text
                            'Next
                        'Next
                        Debug.Print oldmot & " : " & punion.Address: oldmot = mot: Set punion = Nothing
                    End If
                End If
                Set c = plage.Find(mot, Lookat:=xlPart)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        If punion Is Nothing Then Set punion = c Else Set punion = Union(punion, c)
                        addr = addr & c.Address & " "
                        Set c = plage.FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End If
        Next
        .Cells(Rows.Count, 1).End(xlUp) = ""
    End With
End Sub

il te reste le paragraphe bloqué a mettre au point en tout cas dans le debug j'ai les plages
 

dindin

XLDnaute Occasionnel
je regarde un très grand merci à toi aussi
 

dindin

XLDnaute Occasionnel
Avec Compteur


Boisgontier

Merci
j'ai réussi à inclure le compteur dans la même cellule que le mot
ex: mot-15
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
    Nbre = 0
    Application.ScreenUpdating = False
    Cells.Font.Color = vbBlack
    fin = Sheets(2).[B65000].End(xlUp).Row + 1
    ligne = fin
    mot = Target
    For Each c In [b2:b10000]
      p = 1: témoin = False
      Do While p > 0
        p = InStr(p, c, mot)
        If p > 0 Then
          ligne = ligne + 1
          c.Characters(p, Len(mot)).Font.ColorIndex = 3: Nbre = Nbre + 1
          c.Characters(p, Len(mot)).Font.Bold = True
          p = p + Len(mot)
          témoin = True
        End If
      Loop
      If témoin Then lig = c.Row: Rows(lig).Copy Sheets(2).Cells(ligne, 1)
    Next c
    '[A3] = p & " " & " ( " & Nbre & " )"

    [A3] = Range("A2").Value & "  - " & Nbre
    Range("A3").Characters(InStr(1, Range("A3").Value, Nbre), Len(Nbre)).Font.Name = "Calibri"
    Range("A3").Characters(InStr(1, Range("A3").Value, Nbre), Len(Nbre)).Font.Size = 11
  End If
End Sub

mon objectif maintenant c'est de le coller (le mot recherché et le compteur ) avec le résultat dans l'onglet résultat.
ex : colonne : A mot 15 -------- Colonne B: mot qui veut dire -------------- le reste des colonnes
Colonne B : le mot d'aujourd’hui est le suivant ------------- le reste des colonnes
Colonne B : le mot d'ordre ---------- le reste des colonnes
Etc
y'a t-il une piste SVP ?
Merci d'avance
 

patricktoulon

XLDnaute Barbatruc
re
bonjour
je ne veux pas jouer les trouble fete mais je maintient qu'il y a un soucis avec ton fichier
la preuve en visuel
ce code est on ne peut plus simple il est sensé me donner les adresse en "B" qui ont le mot qui se trouve en A2 tout simplement et la position de depart dans le texte

et le instr me donne toute les lignes sur 2007 et toujours 43 de position
VB:
Sub trans()
    Dim temoins As Boolean, mot$, p&
    With Sheets("base ")
        mot = .[A2].Text
        MsgBox mot
        For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            p = InStr(1, .Cells(i, 2).Value, mot)
            If p > 1 Then Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
        Next
    End With
End Sub
j'ai tourner ca dans tout les sens je n'arrive a rien avec ton fichier
pourtant tu le reconnaîtra le code n'est pas très compliqué
preuve visuelle


souhaitons que ce fichier doive fonctionner uniquement sur ton pc sinon c'est la cata a mon avis
depuis hier je me bats avec ton fichier pour essayer de comprendre ce qui se passe
rien rien rien!!!! impossible de travailler avec correctement
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…