XL 2016 rechercher un mot dans une base

dindin · 9 Décembre 2019

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 · 9 Décembre 2019

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

BOISGONTIER · 9 Décembre 2019

Bonjour,

Cf PJ

Boisgontier

patricktoulon · 9 Décembre 2019

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 · 9 Décembre 2019

sousou à dit:
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 · 9 Décembre 2019

BOISGONTIER à dit:
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 · 9 Décembre 2019

patricktoulon à dit:
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 · 9 Décembre 2019

cf PJ

Boisgontier

patricktoulon · 9 Décembre 2019

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 · 9 Décembre 2019

BOISGONTIER à dit:
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 · 9 Décembre 2019

patricktoulon à dit:

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

je regarde un très grand merci à toi aussi

BOISGONTIER · 9 Décembre 2019

Avec Compteur

Boisgontier

dindin · 10 Décembre 2019

Une cerise sur le gâteau.
Merci boigontier

dindin · 10 Décembre 2019

BOISGONTIER à dit:
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 · 10 Décembre 2019

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

XL 2016 rechercher un mot dans une base

dindin

XLDnaute Occasionnel

Pièces jointes

sousou

XLDnaute Barbatruc

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

dindin

XLDnaute Occasionnel

dindin

XLDnaute Occasionnel

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

dindin

XLDnaute Occasionnel

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

dindin

XLDnaute Occasionnel

dindin

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

Discussions similaires