deplacer cellule suivant 2 conditions vba

obyone

XLDnaute Occasionnel
bonjour,

je souhaite deplacer une cellule suivant 2 conditions.
dans ma feuille MAJ
si il y a un x dans la colonne MAJ alors on deplace la valeur de la colonne 3 dans la feuille de la colonne 2 puis on supprime la ligne

la cellule déplacer devra se trouver dans la seconde colonne du nouveau tableau.

j'ai essayé mais j'ai un bug

merci d'avance
 

Pièces jointes

  • comp2.xlsm
    27.4 KB · Affichages: 72

obyone

XLDnaute Occasionnel
bonjour,

j'ai de nouveau un probleme lors que j'ai plusieurs lignes à copier il me copie seulement 1 ligne sur 2, pourquoi?

Sub Essai()
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False
With Sheets("MAJ")
For i = 2 To 65000
If .Cells(i, 1).Value = "" Then Exit Sub
If .Cells(i, 1).Value = "x" And .Cells(i, 2).Value = "essai" Then .Cells(i, 3).Copy
Sheets("essai").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(i, 1).EntireRow.Delete
Next i
End With
Application.ScreenUpdating = True
End Sub


merci d'avance
 

Pièces jointes

  • comp3.xlsm
    25.2 KB · Affichages: 69

JBARBE

XLDnaute Barbatruc
Bonjour à tous,
En effet pas suffisamment testé !
Nécessaire Fait en ajoutant i = 1 ( permettant de revenir à la ligne 1 + 1 afin de corriger le problème dû à la suppression d'une ligne )

Code:
Sub Essai()
Dim i As Long
Application.ScreenUpdating = False
With Sheets("MAJ")
For i = 2 To 65000
If .Cells(i, 1).Value = "" Then Exit Sub
If .Cells(i, 1).Value = "x" And .Cells(i, 2).Value = "essai" Then .Cells(i, 3).Copy
Sheets("essai").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(i, 1).EntireRow.Delete
i = 1
Next i
End With
Application.ScreenUpdating = True
End Sub


bonne journée !
 

Pièces jointes

  • comp1.xls
    73 KB · Affichages: 76
Dernière édition:

obyone

XLDnaute Occasionnel
boujour,

j'ai une modif de la formule, la colonne 2 change, elle indique le non de la feuille ou "transférer" la ligne...

j'ai essayé ce code la mais ca plante...

Code:
Sub Bouton1_Clic()
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
With Sheets("MAJ")

Range("MAJ").Sort Key1:=Range("A1"), Order1:=xlAscending
If .Cells(I, 1).Value = "" Then Exit Sub

For I = .Cells(2, 1).End(xlDown).Row To 4 Step -1
        If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai" Then
        ligne_vide = Sheets("essai").Cells(Rows.Count, 1).End(xlUp).Row
            If Not Sheets("essai").Cells(ligne_vide, 1) = "" Then ligne_vide = ligne_vide + 1
            For J = 1 To 8
            Sheets("essai").Cells(ligne_vide, J).Value = Sheets("MAJ").Cells(I, J).Value
            Next J
            Sheets("MAJ").Cells(I, 1).EntireRow.Delete
           
        End If
      Next I
      I = 1
     
For I = .Cells(2, 1).End(xlDown).Row To 4 Step -1
        If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "Feuil1" Then
        ligne_vide = Sheets("essai").Cells(Rows.Count, 1).End(xlUp).Row
            If Not Sheets("essai").Cells(ligne_vide, 1) = "" Then ligne_vide = ligne_vide + 1
            For J = 1 To 8
            Sheets("essai").Cells(ligne_vide, J).Value = Sheets("MAJ").Cells(I, J).Value
            Next J
            Sheets("MAJ").Cells(I, 1).EntireRow.Delete
           
        End If
      Next I
      I = 1

End With
   
End Sub


merci d'avance de votre aide
 

Pièces jointes

  • comp2.xlsm
    31.4 KB · Affichages: 68

obyone

XLDnaute Occasionnel
re bonjour,

j'ai fais le code suivant qui fonctionne mais je suis obligé de cliquer 2 fois sur le bouton....


Sub Bouton1_Clic()
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
With Sheets("MAJ")

Range("MAJ").Sort Key1:=Range("A1"), Order1:=xlAscending

If .Cells(2, 1).Value = "" Then Exit Sub

For I = 2 To 30000
If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai" Then
ligne_vide = Sheets("essai").Cells(Rows.Count, 1).End(xlUp).Row
If Not Sheets("essai").Cells(ligne_vide, 1) = "" Then ligne_vide = ligne_vide + 1
For J = 1 To 4
Sheets("essai").Cells(ligne_vide, J).Value = Sheets("MAJ").Cells(I, J).Value
Next J
Sheets("MAJ").Cells(I, 1).EntireRow.Delete

ElseIf .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai2" Then
ligne_vide = Sheets("essai2").Cells(Rows.Count, 1).End(xlUp).Row
If Not Sheets("essai2").Cells(ligne_vide, 1) = "" Then ligne_vide = ligne_vide + 1
For J = 1 To 4
Sheets("essai2").Cells(ligne_vide, J).Value = Sheets("MAJ").Cells(I, J).Value
Next J
Sheets("MAJ").Cells(I, 1).EntireRow.Delete

End If
Next I
I = 1


End With

End Sub

y a t il une solution?
merci d'avance
 

obyone

XLDnaute Occasionnel
bonjour,

j'ai modifié mon code comme ceci

Sub Bouton1_Clic()
Dim I As Long
Dim J As Long


With Sheets("MAJ")



For I = 2 To .Range("A1").CurrentRegion.Rows.Count
If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai" Then
ligne_vide = Sheets("essai").Cells(Rows.Count, 1).End(xlUp).Row
If Not Sheets("essai").Cells(ligne_vide, 1) = "" Then ligne_vide = ligne_vide + 1
For J = 1 To 3
Sheets("essai").Cells(ligne_vide, 2).Value = Sheets("MAJ").Cells(I, J).Value
Next J
Sheets("MAJ").Cells(I, 1).EntireRow.Delete

ElseIf .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai2" Then
ligne_vide = Sheets("essai2").Cells(Rows.Count, 1).End(xlUp).Row
If Not Sheets("essai2").Cells(ligne_vide, 1) = "" Then ligne_vide = ligne_vide + 1
For J = 1 To 3
Sheets("essai2").Cells(ligne_vide, 2).Value = Sheets("MAJ").Cells(I, J).Value
Next J
Sheets("MAJ").Cells(I, 1).EntireRow.Delete

ElseIf .Cells(I, 1).Value = "" Then Exit Sub


End If

I = 1
Next I


End With

End Sub

mais le probleme c'est qu'il me copie que la derniere valeur, j'aimerais qu' apres le clic sur le bouton les valeurs 1 et 2 apparaissent sur leur tableau respectif.

merci d'avance
 

Pièces jointes

  • comp3.xlsm
    32.5 KB · Affichages: 61

JBARBE

XLDnaute Barbatruc
Bonjour à tous,
Comme tu sais programmé, pourquoi n'adapte tu pas ma macro ( du post 7) suivante qui fonctionne ( elle ne te conviens pas ) à ta nouvelle demande !

Code:
Sub Essai()
Dim i As Long
Application.ScreenUpdating = False
With Sheets("MAJ")
For i = 2 To 65000
If .Cells(i, 1).Value = "" Then Exit Sub
If .Cells(i, 1).Value = "x" And .Cells(i, 2).Value = "essai" Then .Cells(i, 3).Copy
Sheets("essai").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(i, 1).EntireRow.Delete
i = 1
Next i
End With
Application.ScreenUpdating = True
End Sub

bonne journée !
 
Dernière édition:

obyone

XLDnaute Occasionnel
re bonjour,
j'ai de nouveau un probleme, cela plante sur cette ligne

ActiveSheet.Paste

si il n'y a pas "essai" ou "essai2" dans la colonne 2

voici mon code

Sub Bouton1_Clic()
Dim I As Long
Dim J As Long

Application.ScreenUpdating = False
With Sheets("MAJ")
For I = 2 To 65000
If .Cells(I, 1).Value = "" Then Exit Sub
If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai" Then .Cells(I, 3).Copy
Sheets("essai").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(I, 1).EntireRow.Delete
If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai2" Then .Cells(I, 3).Copy
Sheets("essai2").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(I, 1).EntireRow.Delete
I = 1
Next I
End With
Application.ScreenUpdating = True



End Sub


merci d'avance...
 

JBARBE

XLDnaute Barbatruc
Re,
A tester :
Code:
Sub Test()
Dim I As Long
Application.ScreenUpdating = False
With Sheets("MAJ")
For I = 2 To 65000
'If .Cells(I, 1).Value = "" Then Exit Sub
If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai" Then
.Cells(I, 3).Copy
Sheets("essai").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(I, 1).EntireRow.Delete
I = 1
ElseIf .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai2" Then
.Cells(I, 3).Copy
Sheets("essai2").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(I, 1).EntireRow.Delete
I = 1
ElseIf .Cells(2, 1) = "" And .Cells(2, 2) = "" And .Cells(3, 1) = "" _
And .Cells(3, 2) = "" And .Cells(3, 3) = "" Then
Exit Sub
ElseIf .Cells(2, 1) <> "" And .Cells(2, 2) = "" And .Cells(2, 3) <> "" Then
Else
I = 1
End If
Next I
End With
Application.ScreenUpdating = True
End Sub
 
Dernière édition:

JBARBE

XLDnaute Barbatruc
Re,
seconde proposition si la colonne C (nom) de la feuille MAJ soit toujours renseignée :
Code:
Sub TestA()
Dim I As Long
Application.ScreenUpdating = False
With Sheets("MAJ")
For I = 2 To 65000
If .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai" Then
.Cells(I, 3).Copy
Sheets("essai").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(I, 1).EntireRow.Delete
I = 1
ElseIf .Cells(I, 1).Value = "x" And .Cells(I, 2).Value = "essai2" Then
.Cells(I, 3).Copy
Sheets("essai2").Select
If Range("B2") = "" Then ' si la cellule B2 est vide alors
Range("B2").Select ' cellule B2 selectionnée
Else ' sinon
Range("B1").End(xlDown).Offset(1, 0).Select 'une cellule vide plus bas que la selection selectionnée
End If
ActiveSheet.Paste ' cellule B2 copiée
Application.CutCopyMode = False
Sheets("MAJ").Cells(I, 1).EntireRow.Delete
I = 1
ElseIf .Cells(I, 1) = "" And .Cells(I, 2) = "" And .Cells(I, 3) = "" Then
Exit Sub
ElseIf .Cells(I, 1) = "" And .Cells(I, 2) = "" And .Cells(I, 3) <> "" Then
Else
I = 1
End If
Next I
End With
Application.ScreenUpdating = True
End Sub
 
Dernière édition: