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

patricktoulon · 10 Décembre 2019

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

Code:

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

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

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

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

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

VB:

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

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

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

VB:

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

enfin ça fonctionne chez toi

patricktoulon · 10 Décembre 2019

re
la mienne oui

dindin · 10 Décembre 2019

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

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

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

dindin · 11 Décembre 2019

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

VB:

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

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

re
bonsoir excuse j'ai eu du boulot

VB:

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

tes lignes
tes mots colorés
tes mot en debut de copie en "A"
et le compteur

XL 2016 rechercher un mot dans une base

dindin

XLDnaute Occasionnel

Pièces jointes

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

dindin

XLDnaute Occasionnel

dindin

XLDnaute Occasionnel

dindin

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

Discussions similaires