VBA boucle ou sélection multiple

Question

Bonjour,
Je cherche à utiliser la fonction "recheche" d'Excel et que toutes les valeurs trouvée soit copier dans une autre feuille. Mais j'ai des petits souci de boucle... Aidez moi SVP !!
Ci dessous le code :

Sub recherche()
'
' recherche Macro
'
On error Goto message_box
    Cells.Find(What:="blablabla", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate         'fonction recherche
    ActiveCell.Copy
    Sheets("Feuil3").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Feuil1").Select      'copie et colle le résultat contenant blablabla

Do Until Cells.FindNext(After:=ActiveCell).Value <> Sheets("Feuil3").Range("A1").Value 
'en théorie çà doit faire, jusqu'à ce que la valeur trouver soit égale à la première
ActiveCell.Copy   
Sheets("Feuil3").Select
        Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
ActiveSheet.Paste             'copie et colle dans la première cellule vide de la colonne ASheets("Feuil1").Select
Loop              'fait la boucle pour tout trouver
    
'mais çà, çà marche pas !!    
        
message_box:         Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Il n'y a pas d'éléments comprenant la valeur souhaitée ou ERREUR"    ' Définit le message.
Style = vbDefaultButton2    ' Définit les boutons.
Title = "Information "    ' Définit le titre.
Help = "DEMO.HLP"    ' Définit le fichier d'aide.
Ctxt = 1000    ' Définit le contexte de la rubrique.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)

End Sub

Merci de m'aider, parce que çà fait un petit moment que je cherche sans réussite !!
PS : je crois que vous l'aurez remarqué, je débute...
Merci
Bye
Petit1986

Bidouilleu_R · Answer

tu mélanges la source et le but. 
Essaie ça!
Attention les données en feuille 3 ne sont pas effacées et viennent s'ajouter dans la colonne A




Sub recherche()
'
' recherche Macro
'
On Error GoTo message_box
Sheets("feuil1").Select

'Cells.Find(What:="blablabla", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate 'fonction recherche
'ActiveCell.Copy

With Worksheets("feuil1").Range("a1:a500")
    Set c = .Find("blablabla", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.Copy
            Sheets("feuil3").Select
            Range("A65535").End(xlUp).Offset(1, 0).Select
            ActiveSheet.Paste
            Sheets("feuil1").Select
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With


message_box: Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Il n'y a pas d'éléments comprenant la valeur souhaitée ou ERREUR" ' Définit le message.
Style = vbDefaultButton2 ' Définit les boutons.
Title = "Information " ' Définit le titre.
Help = "DEMO.HLP" ' Définit le fichier d'aide.
Ctxt = 1000 ' Définit le contexte de la rubrique.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)

End Sub

Bidouilleu_R · Answer

j'avais laissé le message pour te faire plaisir, mais de cette manière la macro
ne passera jamais dans le message car la boucle infinie est traitée avec le contrôle de la première adresse
et les vides sont exclus saauf si ce que tu recherche n'existe pas.

donc 1°) la macro fonctionne ( je vérifie ce que je post)
2°) tu aurais pu vérifié le résultat en feuille 3 à partir de laligne A2 avant de dire " ça marche pas"
3°) il est normal que le message se soit affiché, j'ai ajouté une ligne noté en gras
4°) Note que tu peux remplacer "blablabla par une variable.



Sub recherche()
'
' recherche Macro
'
On Error GoTo message_box
Sheets("feuil1").Select


With Worksheets("feuil1").Range("a1:a500")
    Set c = .Find("blablabla", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            c.Copy
            Sheets("feuil3").Select
            Range("A65535").End(xlUp).Offset(1, 0).Select
            ActiveSheet.Paste
            Sheets("feuil1").Select
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
GoTo fin

message_box: Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Il n'y a pas d'éléments comprenant la valeur souhaitée ou ERREUR" ' Définit le message.
Style = vbDefaultButton2 ' Définit les boutons.
Title = "Information " ' Définit le titre.
Help = "DEMO.HLP" ' Définit le fichier d'aide.
Ctxt = 1000 ' Définit le contexte de la rubrique.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)

fin:

s = MsgBox("Tout s'est bien passé!", vbOKOnly, "Sortie du programme")End Sub

Bidouilleu_R · Answer

Oups!
j'ai oublié la ligne en gras

Goto Fin

et bien sur 

Fin:
end sub

VBA boucle ou sélection multiple

3 réponses

Discussions similaires

Newsletters