condition "oui"

[Fabienne]

Bonjour le forum,

est-ce qu'il existe un moyen d'écrire une macro plus simple
que :

Sub Archiver()
Dim Plage As Range, Cel As Range
Dim Ligne1 As Integer

Ligne1 = Sheets('Priorités').Range('P6000').End(xlUp).Row + 1
'Définition de la plage à examiner dans la feuille Priorités
Set Plage = Sheets('Priorités').Range('P6:O' & Ligne1)
'Boucle sur la plage définie
L2 = Sheets('ArchivageFR').Range('A65000').End(xlUp).Row
For Each Cel In Plage
If Cel = 'oui' Then
'If Cel <> '' And Cel = 'oui' Then
L2 = L2 + 1
Cel.EntireRow.Range('A1:O1').Copy Sheets('ArchivageFR').Range('A' & L2)
'supprime la ligne qui a été copiée
Cel.EntireRow.Delete
End If
Next Cel
___

Le but étant de renvoyer dans la feuille 'ArchivageFR'la ligne correspondante si dans la colonne P de la feuille Priorités il y aun 'oui'...mais ma macro ne fonctionne pas très bien.

Merci d'avance pour votre attention

fabienne

 

[adebrux]

Salut Fabienne,

As-tu essayé un code du style, dans le cas ou tes oui ne sont que dans la colonne P:

Private Sub archiver()
Dim L2, i As Integer

With Sheets('priorites')
For i = 1 To Range('P65000').End(xlUp).Row
     If Cells(i, 15).Value = 'oui' Then 'cells(i,15) c'est les cellusles de la colonne P et à la ligne i
          L2 = Sheets('ArchivageFR').Range('A65000').End(xlUp).Rows + 1
          Rows(i).Select
          Selection.Cut
          Sheets('ArchivageFR').Select
          Cells(L2, 1).Select
          ActiveSheet.Paste
          Sheets('proprietes').Activate
          Rows(i).Select
          Selection.delet shift:=xlUp
          i = i - 1
     End If
Next i
End With
End Sub

Attention, ca risque de faire une erreur du au fait que je modifie le i dans la boucle. Il y a aussi le fait que je n'ai pas testé le code dans un fichier...

Bon courage

Arnaud

 

[Fabienne]

Salut Arnaud,le forum..

Merci pour ta proposition mais malheureuseemnt ça ne marche pas
je t'envoie le fichier pour que tu (vous) comprennes mon besoin

En fait si il y a un 'oui' dans la colonne(F) réparée de la
feuille Priorités j'aimerais prendre cette ligne la copié
et la mettre dans la première ligne vide de la feuille Archivage
et qu'elle soit ensuite supprimée dans la feuille Priorités

en esperant avoir été assez clair ....merci d'avance et bonne fin de journée

Fabienne [file name=Archivage_20051108162814.zip size=8685]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Archivage_20051108162814.zip[/file]

 

[adebrux]

Salut Fabienne,

Mon code était bon, à une ou deux erreures de syntaxe près !!!

Maintenant, je teste le oui dans la cellule f, ce qui dans le code se traduit par cells(i,6). Le 6 représente le numéro de la colone. 6 est le numéro de la colonne F... Donc si tu veux faire un test sur une autre colonne, il suffit de changer ce 6 par ce que tu veux (A:1, B:2, C:3 etc..)

Je te joint mon fichier en zip. Tu click sur archiver, ca marche !!!

Je suis sur que si des gens biens comme celeda, @+thierry, andré ou tout autre barbatruc !!! de ce forum lisent mon code, ils auront bien des optimisation à faire, et je les observeraient avec gratitude afin de pouvoir améliorer my VBAlevel !!!

A bientôt et bonne continuation [file name=Archivage_20051108171123.zip size=8074]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Archivage_20051108171123.zip[/file]

 

[Charly2]

Bonsoir Fabienne et Arnaud, bonsoir le forum,

Une seconde solution avec Find et FindNext :

Sub Archiver()
'
Dim CelluleTrouvee As Range
Dim LigneArchive As Long
'
Application.ScreenUpdating = False

LigneArchive = Sheets('ArchivageFR').Range('A65536').End(xlUp).Row + 1

Sheets('Priorités').Activate
Range('P').Select
Set CelluleTrouvee = Selection.Find(what:='oui', LookIn:=xlValues)
Do While Not CelluleTrouvee Is Nothing
CelluleTrouvee.EntireRow.Copy Sheets('ArchivageFR').Rows(LigneArchive)
CelluleTrouvee.EntireRow.Delete
LigneArchive = LigneArchive + 1
Set CelluleTrouvee = Selection.FindNext
Loop

Range('A1').Select
End Sub

Si tu vois des &n bsp, tu les supprimes

Bonne soirée
Charly

 

[Charly2]

Loupé ! Je recommence :

Sub Archiver()
'
Dim CelluleTrouvee As Range
Dim LigneArchive As Long
'
  Application.ScreenUpdating = False
  
  LigneArchive = Sheets('ArchivageFR').Range('A65536').End(xlUp).Row + 1
  
  Sheets('Priorités').Activate
  Range('P:P').Select
  Set CelluleTrouvee = Selection.Find(what:='oui', LookIn:=xlValues)
  Do While Not CelluleTrouvee Is Nothing
    CelluleTrouvee.EntireRow.Copy Sheets('ArchivageFR').Rows(LigneArchive)
    CelluleTrouvee.EntireRow.Delete
    LigneArchive = LigneArchive + 1
    Set CelluleTrouvee = Selection.FindNext
  Loop
  
  Range('A1').Select
End Sub

Voilà.
@+ Charly

 

[Fabienne]

Bonjour Le Forum,

Merci à Arnaud et Charly pour vos code !!
ça fonctionne à merveille
Bonne journée

Fabienne