XL 2013 Deplacer le contenu des lignes puis remonter les vivantes

tchouss56 · 19 Mars 2018

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 · 20 Mars 2018

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 · 21 Mars 2018

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 · 21 Mars 2018

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 · 21 Mars 2018

Re

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

VB:

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 · 21 Mars 2018

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 · 21 Mars 2018

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)

VB:

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 · 22 Mars 2018

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....

XL 2013 Deplacer le contenu des lignes puis remonter les vivantes

tchouss56

XLDnaute Nouveau

Pièces jointes

fanfan38

XLDnaute Barbatruc

tchouss56

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

fanfan38

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

fanfan38

XLDnaute Barbatruc

Discussions similaires