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

 

[patricktoulon]

re
d'autant plus que je viens de faire un simple copy vers "Résultat" et j'obtient toujour la meme ligne alors que le code est explicit c'est bien la .cells(i,2).entirerow que je copie

Sub raz()
    Sheets(2).Cells.Clear
End Sub
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 > 0 Then
                .Cells(i, 2).EntireRow.Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).EntireRow
                Debug.Print Cells(i, 2).Address(0, 0) & " position " & p

                p = 0
            End If
        Next
    End With
End Sub

preuve visuelle du résultat

tu es d'accords avec moi que c'est pas cohérent ??
d'autant plus que dans le debug j'ai les lignes valides
une histoire a dormir debout ton truc

 

[dindin]

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

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

Franchement je ne comprends pas.
Pour éviter ce problème télécharge le dernier de boisgontier car c'est le fichier que je l'utilise en ce moment.
Il fonctionne à merveille.
Juste l'améliorer dans le futur car j'ai plus de 16000 mots à rechercher.

 

[patricktoulon]

re
je travaille avec celui de jacques et ca n'est qu'une copie du fichier que tu a donné
c'est une énigme ton truc
des fois ca donne l'impression que tout est inversé la droite c'est la gauche le haut c'est le bas etc......

 

[dindin]

Tu me laisses perplexe.
Le même fichier fonctionne très bien chez moi .
Je l'ai testé sur 2 ordi w10 excel 16 et 19.
Aucun souci.
J'ai cherché jusqu'à présent 89 mots.
Et j'en suis très satisfait du résultat.
Reste qq améliorations pour ganger du temps.
Peut-être car le texte à l'origine en arabe donc de droite à gauche. Que penses-tu

 

[patricktoulon]

re
bon alors la c'est définitivement certain ton fichier est a l'ouest
regarde ce que j'ai fait pour être sur de ce que j'ai dis

Sub raz()
    Sheets(2).Cells.Clear
End Sub
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 > 0 Then
                '.Cells(i, 2).EntireRow.Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).EntireRow
                 Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).Formula = "='base '!" & .Cells(i, 2).Address
                Debug.Print Cells(i, 2).Address(0, 0) & " position " & p

                p = 0
            End If
        Next
    End With
End Sub

autrement dit je ne met pas les veleurs mais la formule "='base '! e et l'adress de la cellule

résultat en visuel c'est pareil j'ai toujours la ligne 1 dans toutes les ligne
PAR CONTRE !!!!!! les formules sont bonnes
vérifions en visuel
Ce lien n'existe plus
autrement dit chaque ligne de Résultat fait référence a une ligne différente de Base mais le texte est toujours le meme

 

[dindin]

Pourquoi fonctionne t - il chez Jacques et chez moi et pas chez toi.
je te propose d'essayer le code de Jacques.
je suis vraiment novice en VBA mais j'essaye de comprendre
sinon ne te prends pas la tête
merci pour tout ce que tu as fais

 

[patricktoulon]

re
autant pour moi c'est vraiment les même valeurs dans les lignes trouvées
tu aurais pu un peu varier les phrases
teste cela

Sub raz()
    Sheets(2).Cells.Clear
End Sub
Sub trans()
    raz
    Dim temoins As Boolean, mot$, p&, x&
    With Sheets("base ")
        mot = .[A2].Text
        MsgBox mot
        firstrow = Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(2).Row
        For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            p = InStr(1, .Cells(i, 2).Value, mot)
            If p > 0 Then
                x = x + 1
                .Cells(i, 2).EntireRow.Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).EntireRow
                Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
                p = 0
            End If
        Next
        MsgBox x
    End With
    'ajout du compteur dans la cellule temoins en "A" dans "Résultat"
    With Sheets("Résultat").Cells(firstrow, 1).End(xlUp)
        .Value = .Value & vbCrLf & "(" & x & " fois)"
    End With
End Sub

 

[dindin]

enfin ça fonctionne chez toi

 

[patricktoulon]

re
la mienne oui

 

[dindin]

Peut-on faire stp une boucle qui va chercher exemple 50 mots se trouvant dans le premier onglet colonne A de A2 à A51 et coller les résultats un après l'autre avec les compteur dans l'onglet résultat
Merci d'avance

 

[patricktoulon]

RE
ben oui tu englobe le tout dans une boucle sur cells de "A" et a chaque changement de tour de boucle"A" on récupe un new firstrow pour démarrer le transfert

 

[dindin]

Facile à dire avec des termes en chinois pour moi. Difficile à faire mdr .... Je vais essayer malgré tout.

 

[dindin]

j'ai essayé de faire une boucle mais elle me sort une erreur

Sub trans()
    Dim temoins As Boolean, mot$, p&, x&
   Dim liste As range 'je déclare la colonne ou se trouve ma liste des mots
  
    With Sheets("base ")
     liste = range("A2:A51") 'liste comporte les valeurs des cellules A2 à A51
     For Each c In liste
        mot = liste.Value
        MsgBox mot
        firstrow = Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(2).Row
        For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            p = InStr(1, .Cells(i, 2).Value, mot)
            If p > 0 Then
                x = x + 1
                .Cells(i, 2).EntireRow.Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).EntireRow
                Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
                p = 0
            End If
        Next
        MsgBox x
      Next c
    End With
    
    'ajout du compteur dans la cellule temoins en "A" dans "Résultat"
    
    With Sheets("Résultat").Cells(firstrow, 1).End(xlUp)
        .Value = .Value & vbCrLf & "(" & x & " fois)"
    End With
End Sub

Peux tu la corriger stp

 

[dindin]

RE
ben oui tu englobe le tout dans une boucle sur cells de "A" et a chaque changement de tour de boucle"A" on récupe un new firstrow pour démarrer le transfert

voir le poste 28 j'ai essayé une boucle mais elle me sort une erreur
peux-tu la corriger stp

 

[patricktoulon]

re
bonsoir excuse j'ai eu du boulot

Sub raz()
    Sheets(2).Cells.Clear
End Sub
Sub trans()
    raz
    Dim temoins As Boolean, mot$, p&, x&, oldmot$
    Application.ScreenUpdating = False
    With Sheets("base ")
        mot = ""
        For Each cel In .Range("A2:A51")
            mot = cel.Text
            If mot <> "" Then
                firstrow = Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
                Sheets("Résultat").Cells(firstrow, 1) = mot

                With Sheets("Résultat").Cells(firstrow, 1).End(xlUp)
                    If mot <> oldmot Then .Value = .Value & vbCrLf & "(" & x & " fois)"
                End With
                x = 0
                oldmot = mot
                For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
                    p = InStr(1, .Cells(i, 2).Value, mot)

                    If p > 0 Then
                        .Cells(i, 2).Characters(p, Len(mot)).Font.ColorIndex = 3
                        x = x + 1
                        .Cells(i, 2).Resize(, 6).Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1)
                        Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
                        p = 0
                    End If
                Next
            End If
        Next
    End With
End Sub

tu a

1. tes lignes
2. tes mots colorés
3. tes mot en debut de copie en "A"
4. et le compteur