programme VBA copier/coller Résolu/Fermé

Question

Bonjour,

Voilà mon problème, j'ai un fichier Excel avec une liste, des cellules contiennent un texte toujours identique, avec un texte en dessous chaque fois différent, mon souci est de vouloir automatiser un copier/coller dans une autre feuille le texte qui se trouve sous le texte identique l'un en-dessous de l'autre ci-joint une image illustrant mon problème

Sachant que la liste originale peut avoir un nombre de ligne différent à chaque fois

Windows / Chrome 119.0.0.0

NonoM45 · Answer

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+

thev · Answer

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

Programme VBA copier/coller

2 réponses

Discussions similaires