Microsoft 365 Code VBA Recherche par mots clés

looky62

XLDnaute Occasionnel
Hello la communauté,

Je suis bloqué sur mon codage, qui peut m'éclairer

En feuil2 colonne A, ligne avec du texte, je souhaite insérer en colonne B les mots recherchés qui se trouve dans la feuil1 a partir de A2, si les mots recherches à partir de la colonne B à partir de B2, alors mettre le mot qui correspond a la colonne A, exemple , si en feuil1 se trouve un mot en B4 dans la feuil2 alors mettre le mot correspondant à la ligne en A4 et ainsi de suite, de base ma macro ne trouve pas les mots, pourtant je respecte bien l'orthographe d'où vient le pb?

Serait il possible d'ajouter plusieurs mots clés a chercher par exemple, si différente orthographe, entre: résiliation, resiliation, résil, à résilier, ce qui ramenerai en colonne B de la feuil2 le mot Résiliation à faire!

Sub RechercherMots()

' Déclaration des variables
Dim Feuil1 As Worksheet
Dim Feuil2 As Worksheet
Dim DernLigne1 As Long
Dim DernLigne2 As Long
Dim i As Long
Dim j As Long
Dim MotRecherche As String

' Récupération des références aux feuilles de calcul
Set Feuil1 = ThisWorkbook.Worksheets("Feuil1")
Set Feuil2 = ThisWorkbook.Worksheets("Feuil2")

' Trouver la dernière ligne contenant des données dans chaque feuille
DernLigne1 = Feuil1.Cells(Rows.Count, "A").End(xlUp).Row
DernLigne2 = Feuil2.Cells(Rows.Count, "A").End(xlUp).Row

' Parcourir chaque ligne de la colonne B de la feuille 2
For i = 2 To DernLigne2
' Récupérer le mot à rechercher dans la colonne B de la feuille 2
MotRecherche = Feuil2.Cells(i, "B").Value
' Parcourir chaque ligne de la colonne A de la feuille 1
For j = 2 To DernLigne1
' Vérifier si le mot à rechercher se trouve dans la colonne B de la feuille 1
If Feuil1.Cells(j, "B").Value = MotRecherche Then
' Insérer le mot correspondant dans la colonne B de la feuille 2
Feuil2.Cells(i, "A").Value = Feuil1.Cells(j, "A").Value
' Sortir de la boucle de recherche dans la feuille 1 pour passer au mot suivant
Exit For
End If
Next j
Next i

End Sub
 

fanch55

XLDnaute Barbatruc
Bonjour,
SI vous voulez partager du code, utilisez le bouton approprié sur la conversation,
c'est plus agréable et clair à lire ... 👍
1680161837757.png
 

looky62

XLDnaute Occasionnel
VB:
Sub RechercherMots()

' Déclaration des variables
Dim Feuil1 As Worksheet
Dim Feuil2 As Worksheet
Dim DernLigne1 As Long
Dim DernLigne2 As Long
Dim i As Long
Dim j As Long
Dim MotRecherche As String

' Récupération des références aux feuilles de calcul
Set Feuil1 = ThisWorkbook.Worksheets("Feuil1")
Set Feuil2 = ThisWorkbook.Worksheets("Feuil2")

' Trouver la dernière ligne contenant des données dans chaque feuille
DernLigne1 = Feuil1.Cells(Rows.Count, "A").End(xlUp).Row
DernLigne2 = Feuil2.Cells(Rows.Count, "A").End(xlUp).Row

' Parcourir chaque ligne de la colonne B de la feuille 2
For i = 2 To DernLigne2
' Récupérer le mot à rechercher dans la colonne B de la feuille 2
MotRecherche = Feuil2.Cells(i, "B").Value
' Parcourir chaque ligne de la colonne A de la feuille 1
For j = 2 To DernLigne1
' Vérifier si le mot à rechercher se trouve dans la colonne B de la feuille 1
If Feuil1.Cells(j, "B").Value = MotRecherche Then
' Insérer le mot correspondant dans la colonne B de la feuille 2
Feuil2.Cells(i, "A").Value = Feuil1.Cells(j, "A").Value
' Sortir de la boucle de recherche dans la feuille 1 pour passer au mot suivant
Exit For
End If
Next j
Next i

End Sub
 

job75

XLDnaute Barbatruc
Bonjour looky62, le fil,

La gymnastique que vous voulez faire est bien compliquée alors qu'il suffit de filtrer avec le filtre avancé :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim critere
critere = Split(Application.Trim([C1]), ", ") 'attention au séparateur
If UBound(critere) = -1 Then ShowAllData: Exit Sub
Application.EnableEvents = False 'désactive les évènements
ThisWorkbook.Names.Add "Crit", critere 'nom défini
[H2] = "=SUMPRODUCT(N(ISNUMBER(SEARCH(Crit,A2))))" 'critere de filtrage
[A1].CurrentRegion.AdvancedFilter xlFilterInPlace, [H1:H2] 'filtre avancé
[H2] = ""
Application.EnableEvents = True 'réactive les évènements
End Sub
A+
 

Pièces jointes

  • MotifsMotsCles.xlsm
    42 KB · Affichages: 5

looky62

XLDnaute Occasionnel
Bonjour looky62, le fil,

La gymnastique que vous voulez faire est bien compliquée alors qu'il suffit de filtrer avec le filtre avancé :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim critere
critere = Split(Application.Trim([C1]), ", ") 'attention au séparateur
If UBound(critere) = -1 Then ShowAllData: Exit Sub
Application.EnableEvents = False 'désactive les évènements
ThisWorkbook.Names.Add "Crit", critere 'nom défini
[H2] = "=SUMPRODUCT(N(ISNUMBER(SEARCH(Crit,A2))))" 'critere de filtrage
[A1].CurrentRegion.AdvancedFilter xlFilterInPlace, [H1:H2] 'filtre avancé
[H2] = ""
Application.EnableEvents = True 'réactive les évènements
End Sub
A+
Merci pour votre approche, toutefois l idée est de faire ensuite un TCD avec mon résultat, car là j'ai mis qq exemples, mais mon fichier fait 10000lignes, pas évitdent mais l'approche m a appris qq chose!
 

job75

XLDnaute Barbatruc
Bonjour looky62, le forum,

Bon puisque vous y tenez voyez le fichier joint et cette macro, toujours avec le filtre avancé :
VB:
Private Sub Worksheet_Activate()
Dim P As Range, titre$, i&, critere
Set P = [A1].CurrentRegion
titre = P(1, 2)
Application.ScreenUpdating = False
P.Columns(2).ClearContents 'RAZ
With Sheets("Feuil1").[A1].CurrentRegion 'feuille des critères
    For i = 2 To .Rows.Count
        critere = Split(Application.Trim(.Cells(i, 2)), ", ") 'attention au séparateur
        If UBound(critere) >= 0 Then
            ThisWorkbook.Names.Add "Crit", critere 'nom défini
            [H2] = "=SUMPRODUCT(N(ISNUMBER(SEARCH(Crit,A2))))" 'critere de filtrage
            P.AdvancedFilter xlFilterInPlace, [H1:H2] 'filtre avancé
            P.Columns(2).SpecialCells(xlCellTypeVisible) = .Cells(i, 1) 'remplissage
        End If
    Next
End With
If FilterMode Then ShowAllData 'RAZ
[H2] = ""
P(1, 2) = titre
End Sub
Elle se déclenche quand on active la 1ère feuille.

A+
 

Pièces jointes

  • MotifsMotsCles(1).xlsm
    42.6 KB · Affichages: 5

Discussions similaires

Réponses
4
Affichages
450

Statistiques des forums

Discussions
315 096
Messages
2 116 175
Membres
112 677
dernier inscrit
Justine11