Copier/Coller

[Hulk]

Hello,

Je voudrais savoir pourquoi ces codes ne fonctionnent pas ?

Private Sub BtnRecherche_Click()

    Dim x As Range
    Dim Mot
        
    On Error Resume Next
        
    Mot = InputBox("Quel mot recherchez-vous ?", "")
    
    If Mot = "" Then Exit Sub
    
    For Each x In Sheets("Feuil1").Range("A2:A" & Range("A65536").End(xlUp).Row)
        If x = Mot Then
            x.EntireRow.Copy
            Sheets("Feuil2").Select
            Range("A1").Select
            ActiveSheet.Paste
        End If
    Next x
    
End Sub

Ou

Private Sub BtnRecherche_Click()

    Dim x As Range
    Dim Mot
        
    On Error Resume Next
        
    Mot = InputBox("Quel mot recherchez-vous ?", "")
    
    If Mot = "" Then Exit Sub
    
    For Each x In Sheets("Feuil1").Range("A2:A" & Range("A65536").End(xlUp).Row)
        If x = Mot Then
            x.EntireRow.Copy
            Sheets("Feuil2").Select
            Range("A1:A" & Range("A65536").End(xlUp).Row).Select
            ActiveSheet.Paste
        End If
    Next x
    
End Sub

Au fait, je souhaiterais qu'il copie la ligne puis la colle dans la dernière ligne vide (ou au moins ewn A1) de la feuille 2.

Pourtant en sélectionnant d'abord une cellule de la colonne A de la feuille 2, ce code fonctionne...

Private Sub BtnRecherche_Click()

    Dim x As Range
    Dim Mot
        
    On Error Resume Next
        
    Mot = InputBox("Quel mot recherchez-vous ?", "")
    
    If Mot = "" Then Exit Sub
    
    For Each x In Sheets("Feuil1").Range("A2:A" & Range("A65536").End(xlUp).Row)
        If x = Mot Then
            x.EntireRow.Copy
            Sheets("Feuil2").Select
            ActiveSheet.Paste
        End If
    Next x
    
End Sub

Incompréhensible pour moi 😕

 

[Fo_rum]

Re : Copier/Coller

Salut

déjà,

Sheets("Feuil2").Select
Range("A1:A" & Range("A65536").End(xlUp).Row).Select
ActiveSheet.Paste

la ligne en gras ne correspond pas à la feuil2

Pour ma part je ferai ainsi :

Private Sub CommandButton1_Click()
  Dim x As Range, Li As Long
  Dim Mot
    
    Mot = InputBox("Quel mot recherchez-vous ?", "")
    
    If Mot = "" Then Exit Sub
    
    For Each x In Sheets("Feuil1").Range("A2:A" & Range("A65536").End(xlUp).Row)
      If x = Mot Then
        Li = Li + 1
        x.EntireRow.Copy Sheets("Feuil2").Range("A" & Li)
        
      End If
    Next x
End Sub

 

[TournayreDavid]

Re : Copier/Coller

Salut

Pour ma part le problème vient de :
Range("A1:A" & Range("A65536").End(xlUp).Row).Select

Essaye plutôt:
Range("A1").End(xlDown).Offset(1, 0).Select




Private Sub BtnRecherche_Click()

Dim x As Range
Dim Mot

On Error Resume Next

Mot = InputBox("Quel mot recherchez-vous ?", "")

If Mot = "" Then Exit Sub

For Each x In Sheets("Feuil1").Range("A2:A" & Range("A65536").End(xlUp).Row)
If x = Mot Then
x.EntireRow.Copy
Sheets("Feuil2").Select
Range("A1").End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next x

End Sub

A plus

 

[Hulk]

Re : Copier/Coller

Hello tout le monde,

Ben finalement après essais avec toutes vos propositions, je vais garder la version sans Select de Jean-Marcel... J'imagine que mieux sans le Select.
De plus je découvre le "Destination:=" 😀

Merci à vous tous !!

 

[JNP]

Re : Copier/Coller

Bonsoir le fil 🙂,
Pour le fun, une approche différente

Application.ScreenUpdating = False
    Dim x As Range
    Dim Mot As String, Cellule As Range, FirstAddress
    Mot = InputBox("Quel mot recherchez-vous ?", "")
    Début = Timer
    If Mot = "" Then Exit Sub
With Sheets("Feuil1").Range("A2:A" & Sheets("Feuil1").Range("A65536").End(xlUp).Row)
    Set Cellule = .Find(Mot, LookIn:=xlValues, LookAt:=xlWhole)
    If Not Cellule Is Nothing Then
        FirstAddress = Cellule.Address
        Do
            Cellule.EntireRow.Copy Destination:=Sheets("Feuil2").Range("A" & Sheets("Feuil2").Range("A65536").End(xlUp).Row + 1)
            Set Cellule = .FindNext(Cellule)
        Loop While Not Cellule Is Nothing And Cellule.Address <> FirstAddress
    End If
End With
Application.ScreenUpdating = True

Bonne soirée 😎

 

[Lii]

Re : Copier/Coller

Bon soir,

pour la rapidité (10s environ pour 12000 lignes)

Sub Lii()
  Dim VCel As Range, VLi As Long
  Dim Mot, T
  Application.ScreenUpdating = False
  Sheets("feuil2").Cells.Clear
  Do
    Mot = InputBox("Quel mot recherchez-vous ?", "")
  Loop Until Mot <> ""
  T = Timer
  VLi = 1
  For Each VCel In Range("A2:A" & [A65536].End(xlUp).Row)
    If VCel Like Mot Then
      VLi = VLi + 1
      VCel.EntireRow.Copy Sheets("Feuil2").Range("A" & VLi)
    End If
  Next
  If Sheets("Feuil2").[A1] = "" Then Sheets("Feuil2").Rows("1:1").Delete
  [A1] = Timer - T
End Sub

Autre variante :

Sub Lii2()
  Dim VCl As Range, VL As Long, VLi As Long
  Dim Mot, T
  Application.ScreenUpdating = False
  Sheets("feuil2").Cells.Clear
  Mot = InputBox("Quel mot recherchez-vous ?", "")
  If Mot = "" Then Exit Sub
  T = Timer
  For VL = 1 To [A65536].End(xlUp).Row
    With Range("A" & VL)
      Set VCl = .Find(Mot, LookIn:=xlValues, LookAt:=xlWhole)
      If Not VCl Is Nothing Then
        VLi = VLi + 1
        VCl.EntireRow.Copy Sheets("Feuil2").Range("A" & VLi)
      End If
    End With
  Next
  If Sheets("feuil2").[A1] = "" Then Sheets("feuil2").Rows("1:1").Delete
  [D1] = Timer - T
End Sub