XL 2016 rechercher un mot dans une base

[dindin]

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

 

[sousou]

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

 

[BOISGONTIER]

Bonjour,

Cf PJ


Boisgontier

 

[patricktoulon]

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

 

[dindin]

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]

Bonjour,

Cf PJ


Boisgontier

Bonjour
merci Boisgontier
Seulement souci , si je recherche un 2 ème mot , ce dernier efface le premier résultat collé dans onglet Résultat
y 'a t_il pas une possibilité qu'il se colle à la suite et non à la place
merci d'avance

 

[dindin]

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"
Regarde la pièce jointe 1048437

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

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

 

[BOISGONTIER]

cf PJ

Boisgontier

 

[patricktoulon]

re
avec ton dernier fichier
regarde dans le debug

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]

cf PJ

Boisgontier

Très grand merci
je vais trouver une solution pour le comptage de fois chaque mot a été répété

 

[dindin]

re
avec ton dernier fichier
regarde dans le debug

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

je regarde un très grand merci à toi aussi

 

[BOISGONTIER]

Avec Compteur


Boisgontier

 

[dindin]

Une cerise sur le gâteau.
Merci boigontier

 

[dindin]

Avec Compteur


Boisgontier

Merci
j'ai réussi à inclure le compteur dans la même cellule que le mot
ex: mot-15

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]

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

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