Programme VBA copier/coller
Résolu
mike7182
Messages postés
7
Date d'inscription
Statut
Membre
Dernière intervention
-
mike7182 Messages postés 7 Date d'inscription Statut Membre Dernière intervention -
mike7182 Messages postés 7 Date d'inscription Statut Membre Dernière intervention -
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
A voir également:
- Vba copier coller
- Historique copier coller - Guide
- Copier coller pdf - Guide
- Copier-coller - Accueil - Informatique
- Style d'écriture a copier coller - Guide
- Arobase copier coller - Forum Windows 10
2 réponses
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
merci
ce petit programme m'a bien aidé avec quelques modifications pour ce que je voulais exactement j'ai réussi à obtenir le résultat que je voulais
encore merci NonoM45