Recherche de mot depuis une liste

Bonjour à tous,

Aujourd'hui j'utilise une instruction me permettant de faire une boucle dans un tableau et me copier coller vers une autre sheet quand un mot bien spécifique est retrouvé.

J'aimerais pouvoir faire une boucle sur une liste de mot - Que je placerais dans un autre onglet

Ex:

023A

023B

023C

etc...

Pourriez vous m'aider?

DernLigne = Range("A" & Rows.count).End(xlUp).Row

For i = 6 To DernLigne

Worksheets("Data").Select

If Range("A" & i) = "023A" Then

ActiveSheet.Rows(i).Select

Selection.Copy

Worksheets("Résultat").Select

ActiveSheet.Cells(Rows.count, "A").End(xlUp)(2).Select

Selection.PasteSpecial Paste:=xlPasteValues

i = i + 1

Else

End If

Next

D'avance un grand merci,

Bonjour,

Pour éviter tout malentendu ... surtout par rapport à la localisation de ta liste de mots ... il serait judicieux de joindre ton fichier ...

Bonjour,

Ah!!!! Je pensais l'avoir introduis

Au temps pour moi.

Voici le fichier (voir module 1)

c'est dans cette boucle que j'aimerais pouvoir l'excercice

Bàv

Kwld

bonjour Kwld,

bonjour le Forum,

une proposition

Sub aargh()
    with Sheets("data")
    dl = .Cells(Rows.count, 1).End(xlUp).Row
    Set pl = .Range("A1:A" & dl)
    end with
    With Sheets("liste")
        dl = .Cells(Rows.count, 1).End(xlUp).Row
        lm = .Range("A2:A" & dl)
    End With
    Set wsr = Sheets("résultat")
    wsr.Cells.ClearContents
    wsr.Range("A1") = "Entité"
    k = 1
    For i = LBound(lm) To UBound(lm)
        Set re = pl.Find(lm(i, 1), lookat:=xlWhole)
        If Not re Is Nothing Then
            fa = re.Address
            Do
                k = k + 1
                wsr.Cells(k, 1) = lm(i, 1)
                wsr.Cells(k, 2) = re.Row
                Set re = pl.FindNext(re)
            Loop Until re Is Nothing Or re.Address = fa
        End If
    Next i
End Sub

Bonjour,

Ca fonctionne superbement bien sauf que ça ne me recopie pas ma ligne entière : -/

Bien à vous,

kwld

J'arrive trop tard, acide est passé par là... , Je donne comme même mon code ?!

Sub boucle_test()
    Application.ScreenUpdating = False
    Dim Ligne_Data As Long, Ligne_Résultat As Long, Ligne_Liste As Long
    Ligne_Data = 2
    Ligne_Résultat = 2
    Ligne_Liste = 2
    With Sheets("Liste")
        Do
            If .Cells(Ligne_Liste, 1).Value = "" Then Exit Do
            Do
                If Sheets("Data").Cells(Ligne_Data, 1).Value = "" Then Exit Do
                If Sheets("Data").Cells(Ligne_Data, 1).Value = .Cells(Ligne_Liste, 1).Value Then
                    Sheets("Résultat").Cells(Ligne_Résultat, 1).Value = .Cells(Ligne_Liste, 1).Value
                    Ligne_Résultat = Ligne_Résultat + 1
                End If
                Ligne_Data = Ligne_Data + 1
            Loop
            Ligne_Data = 2
            Ligne_Liste = Ligne_Liste + 1
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

vbMBHB

Bonjour,

Idem

Pas ma ligne

Merci

Kwld

Kwld a écrit :

Bonjour,

Ca fonctionne superbement bien sauf que ça ne me recopie pas ma ligne entière : -/

Bien à vous,

kwld

re-bonjour à tous

ma boule de cristal ne m'a pas communiqué cette demande, je suis désolé...

remplace ces instructions

wsr.Cells(k, 1) = lm(i, 1)
wsr.Cells(k, 2) = re.Row

par

re.EntireRow.Copy wsr.Rows(k)

Fonctionne parfaitement!

Un tout grand merci à vous

A bientôt

kwld

Je me permets de relancer le débat...

Mettons que je recherche une partie de mot?

Exemple:

"Corporate Express"

Et que dans ma liste de mots de recherche je ne mette que "Express"

Que devrais-je faire?

Bàv

Kwld

bonsoir,

bonsoir le forum,

pour une recherche partielle

Sub aargh()
    With Sheets("data")
        dl = .Cells(Rows.count, 1).End(xlUp).Row
        Set pl = .Range("A1:A" & dl)
    End With
    With Sheets("liste")
        dl = .Cells(Rows.count, 1).End(xlUp).Row
        lm = .Range("A2:A" & dl)
    End With
    Set wsr = Sheets("résultat")
    wsr.Cells.ClearContents
    wsr.Range("A1") = "Entité"
    k = 1
    For i = LBound(lm) To UBound(lm)
        Set re = pl.Find(lm(i, 1), lookat:=xlPart)
        If Not re Is Nothing Then
            fa = re.Address
            Do
                k = k + 1
                re.EntireRow.Copy wsr.Rows(k)
                Set re = pl.FindNext(re)
            Loop Until re Is Nothing Or re.Address = fa
        End If
    Next i
End Sub

Bonsoir,

Merci pour cet update. Je confirme que ça fonctionne

Par contre, assez limité quand utilisé sur gros fichier

Dans mon cas ==> 145.000 lignes

Dans quel mesure pensez-vous que cela pourraît être optimisé?

Bàv

Kwld

Bonjour,

ce doit être possible. pour faire des tests, j'aimerais disposer de ton fichier si c'est possible.

Bonjour,

Je vais préparer un fichier (car qd mm des données confidentielles dedans et je le poste)

Merci à toi,

Kwld