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
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

XLDnaute Occasionnel

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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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
 

dindin

XLDnaute Occasionnel
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
 

patricktoulon

XLDnaute Barbatruc
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
  1. tes lignes
  2. tes mots colorés
  3. tes mot en debut de copie en "A"
  4. et le compteur
 

Discussions similaires

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