va chercher 1 ou plusieurs lignes

[JANO]

Bonjour le Forum,

j'ai une macro rechercher et sélectionne une ligne.
Puis une autre que colle la ligne dans une autre feuille.

Cela fonctionne bien pour une ligne, mais je n'arrive pas à modifier la macro pour quand le numéro comporte plusieurs lignes.

Sub vachercher()
'Cherche le numéro de formulaire à modifier et lance macro modifier
On Error GoTo gestionerreur
Mot = InputBox("Entrer le numéro ", "test")
If Mot = "" Then Exit Sub
Sheets("base").Select
With Worksheets("base").Cells
.Range("A1:A5000").Select
.Find(What:=Mot, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
End With
' Sous-programme de gestion d'erreur
gestionerreur:
If Err.Number = 91 Then
msg1 = "N° d'archive non référencé ! " & Chr(13) & "L’erreur est " & Str(Err.Number)
MsgBox msg1
Exit Sub
Else
Sheets("base").Select
With Worksheets("base").Cells
.Range(ActiveCell(), ActiveCell.Offset(0, 8)).Select
End With
End If
Call modifier
End Sub
-----------------------------------------------------------------
Sub modifier()
Application.ScreenUpdating = False
Selection.Copy
Sheets("modifier").Range("A" & Sheets("modifier").Range("A65536").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
Sheets("base").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("B1").Select
Sheets("modifier").Select
Range("B1").Select
End Sub


Pouvez-vous m'aider?
ci-joint également le fichier
merci

 

[pierrejean]

Re : va chercher 1 ou plusieurs lignes

Bonjour JANO

Je me suis permis de reprendre entierement tes macros car elles ne sont vraiment pas au top
Je crois que tu comprendras la mienne ,surtout si tu va en F1 apres avoir selectionné Findnext

 

[JANO]

Re : va chercher 1 ou plusieurs lignes

Merci PierreJean,
Très intéressant le Findnext.
Encore merci

 

[JANO]

Re : va chercher 1 ou plusieurs lignes

Rebonjour,
je ne dois pas avoir bien compris, car j'essaye de modifier le code pour qui supprime les données qui ont été rapatrier.
Mais cela bug !

Sub copie()
Mot = InputBox("Entrer le numéro ", "test")
If Mot = "" Then Exit Sub
Set c = Sheets("base").Columns(1).Find(Mot, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Sheets("base").Range("A" & c.Row & ":I" & c.Row).Copy Destination:=Sheets("modifier").Range("A" & Sheets("modifier").Range("A65536").End(xlUp).Row + 1)
Set c = Sheets("base").Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress

Do
Sheets("base").Range("A" & c.Row & ":I" & c.Row).Delete Shift:=xlUp
Set c = Sheets("base").Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress

Else
MsgBox (" non référencé ! ")
End If
End Sub

merci

 

[pierrejean]

Re : va chercher 1 ou plusieurs lignes

Re

Sub copie()
Mot = InputBox("Entrer le numéro ", "test")
If Mot = "" Then Exit Sub
Set c = Sheets("base").Columns(1).Find(Mot, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
    Do
      Sheets("base").Range("A" & c.Row & ":I" & c.Row).Copy Destination:=Sheets("modifier").Range("A" & Sheets("modifier").Range("A65536").End(xlUp).Row + 1)
      derlin = c.Row
      Set c = Sheets("base").Columns(1).FindNext(c)
    Loop While Not c Is Nothing And c.Address <> firstAddress
    Sheets("base").Range(firstAddress & ":I" & derlin).ClearContents
Else
  MsgBox ("N° d'archive non référencé  ! ")
End If
End Sub

 

[JANO]

Re : va chercher 1 ou plusieurs lignes

Merci PierreJean,
j 'essaye, mais ...
Encore merci de ton aide