Programme VBA copier/coller

Bonsoir mike7182

Voici une possibilité

Sub Copier_Coller()
  ' Variables
  Dim Sht1 As Worksheet, Sht2 As Worksheet
  Dim dLig1 As Long, Lig1 As Long, nLig2 As Long
  ' Procédure
  Set Sht1 = ThisWorkbook.Sheets("Feuil1")
  Set Sht2 = ThisWorkbook.Sheets("Feuil2")
  dLig1 = Sht1.Range("A" & Rows.Count).End(xlUp).Row
  For Lig1 = 1 To dLig1
    If InStr(1, Sht1.Range("A" & Lig1), "texte à copier", vbTextCompare) > 0 Then
      nLig2 = Sht2.Range("A" & Rows.Count).End(xlUp).Row + 1
      Sht1.Range("A" & Lig1).Copy Destination:=Sht2.Range("A" & nLig2)
    End If
  Next Lig1
End Sub

A+

Bonsoir,

Une autre proposition :

Sub copie_texte()
    Dim texte_à_chercher As String
    Dim cell As Range, cell1 As Range
    
    texte_à_chercher = "XXX"
    Set cell = Feuil1.Cells.Find(texte_à_chercher, LookAt:=xlWhole)
    If Not cell Is Nothing Then
        Set cell1 = cell
        Do
            Set cell_copiée = Feuil2.Columns(1).Find(""): If cell_copiée Is Nothing Then Set cell_copiée = Feuil2.Range("A1")
            cell_copiée.Value = cell.Offset(1).Value
        
            Set cell = Feuil1.Cells.Find(texte_à_chercher, After:=cell)
        Loop Until cell.Address = cell1.Address
    End If

End Sub