XL 2013 Deplacer le contenu des lignes puis remonter les vivantes

[tchouss56]

Bonsoir,

Je veux lancer une macro en cliquant sur le bouton réaliser qui aura comme effet de déplacer le contenu des cellules B et C dont les case à cocher son cochée "cellule en vert" vers la feuil2, puis de remonter le contenu des cellules qui ne sont pas coché. Il ne faut pas supprimer les cellules avec les bordures en gras doivent rester même vide.
Si rien est coché ne rien faire.

Merci

 

[fanfan38]

Bonjour Tchouss56
Voilà la macro que je t'ai concocté...
Sub remonter()
Dim derlig As Integer, i As Integer, j As Integer, k As Integer
derlig = Sheets("Feuil2").Range("a65000").End(xlUp).Row + 1
i = 4
Do While Len(Cells(i, 2).Value) > 0
If Cells(i, 5).Value = True Then
Sheets("Feuil2").Cells(derlig, 1).Value = Cells(i, 2).Value
Sheets("Feuil2").Cells(derlig, 2).Value = Cells(i, 3).Value
derlig = derlig + 1
Cells(i, 2).ClearContents
Cells(i, 3).ClearContents
Cells(i, 5).Value = False
End If
i = i + 2
Loop
For j = 4 To i Step 2
If Len(Cells(j, 2).Value) = 0 Then
For k = j To i
If Len(Cells(k, 2).Value) > 0 Then Exit For
Next
Cells(j, 2).Value = Cells(k, 2).Value
Cells(j, 3).Value = Cells(k, 3).Value
Cells(k, 2).ClearContents
Cells(k, 3).ClearContents
End If
Next
End Sub

A+ François

 

[tchouss56]

Merci,
Cela marche parfaitement.
Que faut-il modifier pour faire exactement la même chose avec des formules "ex : recherchev" dans les cellule pour qu'elles soient conservées.

 

[Staple1600]

Bonjour le fil, le forum


Suggestion en passant (commandée par la prudence )
Plutôt en Long, non ?
Dim derlig As Long, i As Long, j As Integer, k As Integer

 

[Staple1600]

Re

Une autre façon de faire (en utilisant le filtre automatique)

Sub Remonter_B()
Dim Pfil As Range, derL&
Application.ScreenUpdating = False
Feuil1.Range("$B$2:$E$34").AutoFilter Field:=4, Criteria1:="VRAI"
Set Pfil = Feuil1.AutoFilter.Range: derL = Feuil1.Cells(Rows.Count, 1).End(3)(2).Row
    With Feuil2
        Pfil.Offset(1).Columns("A:B").SpecialCells(12).Copy .Cells(derL, 1)
        .Cells(derL, 3).Resize(.Cells(Rows.Count, 1).End(3).Row - 1) = Date
        .[A1].CurrentRegion.Borders.LineStyle = 1
    End With
Feuil1.ShowAllData
End Sub

 

[fanfan38]

Bonjour à tous
Staple 1600 peux tu m'expliquer: derL = Feuil1.Cells(Rows.Count, 1).End(3)(2).Row
le 3 et le 2 après le end... j'avais jamais vu...
Merci
A+ François

 

[Staple1600]

Bonsoir le fil, le forum

@fanfan38
Pourtant déjà utilisé plusieurs fois sur le forum (et pas que par moi)
3= xlUp
2=Offset(1)

Voir ce petit test (à faire sur une feuille vierge)

Sub test()
Randomize 1600
Cells.Clear
[A1].Resize(Int((15 * Rnd) + 1)) = "=INT(ROW()*NOW()/1600)"
'écriture classique
MsgBox Cells(Rows.Count, 1).End(xlUp).Address
MsgBox Cells(Rows.Count, 1).End(xlUp).Offset(1).Address
'écriture moins classique ;-)
MsgBox Cells(Rows.Count, 1).End(3).Address
MsgBox Cells(Rows.Count, 1).End(3)(2).Address
End Sub

 

[fanfan38]

Bonjour et Merci Staple 1600
Comme quoi on en apprend tous les jours...
Je suis de la vieille école
et je ne suis pas un fan de offset....
Mais j'irai dormir moins con se soir... lol ....
A+ Bonne journée....