Coupage / collage de plusieurs lignes

[lancelot92]

Bonjour à tous,

Je viens à vous pour aide concernant la fin d'un programme sur lequel je me suis déjà penché mais où je bloque.

Ma macro est simple : dans un tableau d'une taille dont on se fiche, je souhaite couper les lignes là ou la valeur de cellule en D (colonne) prend une ou une autre certaine valeur, pour ensuite les coller les unes après les autres, 3 lignes en dessous de mon tableau. Jusque là j'arrive à trouver les lignes qui contiennent la valeur que je souhaite, j'arrive à les couper et à me placer 3 lignes en dessous du tableau. Mais je n'arrive pas à les coller une à une !

Voici mon code :

Sub trier_ilots()
Dim Lignesfeuille As String
Lignesfeuille = 110
Dim j As Integer
Dim i As Integer
Dim NoLig As Long


    j = 0
    For i = 2 To 110
    If Range("D" & i).Value = "Magalie Grillon" Or Range("D" & i).Value = "Cédrik Chollet" Then
    Cells(i, 4).EntireRow.Cut
    Selection.Cut
    NoLig = ActiveSheet.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row + 3
    ActiveSheet.Cells(NoLig, 1).Select
    
    ' Il faut que je les copie ici avec une instruction mais comment ?
    
    j = j + 1
    End If
    Next
    
End Sub

Un grand merci à vous pour l'aide que vous pourrez m'apporter...

NB : Je vous transmets mon fichier, le code est dans le module 1

 

[PMO2]

Re : Coupage / collage de plusieurs lignes

Bonjour,

Peut être comme cela

Sub trier_ilots()
Dim Lignesfeuille As String
Lignesfeuille = 110
Dim j As Integer
Dim i As Integer
Dim NoLig As Long


    j = 0
    For i = 2 To 110
    If Range("D" & i).Value = "Magalie Grillon" Or Range("D" & i).Value = "Cédrik Chollet" Then
    
    NoLig = ActiveSheet.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row + 3
    
    
Cells(i, 4).EntireRow.Cut Destination:=Range("a" & NoLig & "")
''    Selection.Cut
    ActiveSheet.Cells(NoLig, 1).Select
    
   
    j = j + 1      '(???)
    End If
    Next
    
End Sub

 

[Paf]

Re : Coupage / collage de plusieurs lignes

Bonjour

après quelques modifications:

Sub trier_ilots()
 Dim Lignesfeuille As String
 Dim j As Integer
 Dim i As Integer, DerLig As Integer, LigneRecopie As Integer
 Dim NoLig As Long
 
 DerLig = Range("A" & Rows.Count).End(xlUp).Row ' dernière ligne à vérifier
 LigneRecopie = DerLig + 3  'première ligne de recopie
 For i = 2 To DerLig '110
    If Range("D" & i).Value = "Magalie Grillon" Or Range("D" & i).Value = "Cédrik Chollet" Then
        Cells(i, 4).EntireRow.Cut Cells(LigneRecopie , 1)
        LigneRecopie = LigneRecopie + 1
     End If
 Next
End Sub

la limite de 110 est remplacée par la dernière ligne réelle à vérifier, sinon les lignes issues de la copie vont se trouver elles mêmes recopiées.
A+

edit Bonjour PM02

 

[lancelot92]

Re : Coupage / collage de plusieurs lignes

Messieurs vos deux réponses me conviennent parfaitement. PMO2, ton programme fonctionne très bien. Paf, le tien est lui aussi parfait, d'autant que l'avantage réside dans le fait que la recopie est ici fonction de la fin du tableau.

J'ai cependant une ultime requête à vous faire : comment puis- je faire pour qu'une fois coupée, la ligne vide se supprime, et qu'ainsi je ne me retrouve pas avec un gruyère ? Je connais ce mini programme mais je ne sais pas l'adapter.

Sub suppr_lignes() 
For lin = Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1 
If Rows(lin).Find("*") Is Nothing Then Rows(lin).Delete 
Next lin 
End Sub

 

[lancelot92]

Re : Coupage / collage de plusieurs lignes

C'est bon, j'ai abouti à un programme qui me plaît. Merci pour tout !

Sub trier_ilots()
 Dim Lignesfeuille As String
 Dim j As Integer
 Dim i As Integer, DerLig As Integer, LigneRecopie As Integer
 Dim NoLig As Long
 
 DerLig = Range("A" & Rows.Count).End(xlUp).Row ' dernière ligne à vérifier
 LigneRecopie = DerLig + 3  'première ligne de recopie
 For i = 2 To DerLig '110
    If Range("D" & i).Value = "Magalie Grillon" Or Range("D" & i).Value = "Cédrik Chollet" Then
        Cells(i, 4).EntireRow.Cut Cells(LigneRecopie, 1)
        LigneRecopie = LigneRecopie + 1
     End If
 Next
On Error Resume Next
    [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    j = 0
    For i = 1 To 150
    If Range("D" & i).Value = "Magalie Grillon" Or Range("D" & i).Value = "Cédrik Chollet" Then
    Cells(i, 4).Select
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Exit For
    End If
Next
    
End Sub

 

[Paf]

Re : Coupage / collage de plusieurs lignes

Re bonjour,

à tester

Sub trier_ilots()
 Dim i As Integer, DerLig As Integer, LigneRecopie As Integer
 
 Application.ScreenUpdating = False ' pour éviter le scintillement 
 DerLig = Range("A" & Rows.Count).End(xlUp).Row ' dernière ligne à vérifier
 LigneRecopie = DerLig + 3  'première ligne de recopie
 For i = DerLig To 2 step -1  ' on commence par la fin pour éviter les décalages
    If Range("D" & i).Value = "Magalie Grillon" Or Range("D" & i).Value = "Cédrik Chollet" Then
        Cells(i, 4).EntireRow.Copy Cells(LigneRecopie , 1) 
        rows(i).delete
        LigneRecopie =Range("A" & Rows.Count).End(xlUp).Row + 1
     End If
 Next
 Application.ScreenUpdating = True
End Sub

A+

 

[lancelot92]

Re : Coupage / collage de plusieurs lignes

Bonjour Paf,

Ton programme est parfait et en plus il est moins lourd que le mien !

Encore merci