Macro - transférer des données d'une feuille à une autre

Bonjour à tous,

Je suis à la recherche d'aide pour créer une macro.

J'ai en ma possession un fichier excel de listing de tous mes projets. Ce fichier est composé de deux onglets :

1 - Tous mes projets notés : non démarrés, en cours et terminés

2 - Mes projets terminés

Mon souhait : écrire une macro qui automatiquement qu'un projet de la feuille 1 est noté comme "Terminé" il soit renvoyé en feuille n°2.

Merci pour votre aide.

N'hésitez pas à me dire si vous avez besoin de plus précisions.

ps : un exemple de mon fichier en pj

Poppy

Bonjour,

à tester,

Sub test()
With Sheets("Fichiers sources - tous projets")
rw = .Cells(Rows.Count, 1).End(xlUp).Row
col = .Cells(5, Columns.Count).End(xlToLeft).Column
Set Rng = .Range(Cells(6, 1).Address, Cells(rw, col).Address)
End With

rw2 = Sheets("Projets terminés").Cells(Rows.Count, 1).End(xlUp).Row + 1

x = Rng(1, 5)
For i = 1 To Rng.Rows.Count
    If Rng(i, 5) = "Terminé" Then
        Sheets("Projets terminés").Rows(rw2).Value = Rng.Rows(i).Value
        rw2 = Sheets("Projets terminés").Cells(Rows.Count, 1).End(xlUp).Row + 1
    End If
Next i
End Sub

Bonjour i20100,

Merci pour ton retour.

Je crois qu'il y a un patit cafouillage mais on y est presque cf le fichier avec la macro en pj.

La macro ne recopie pas bien la ligne dans la feuille deux. Par ailleurs, la recopie ne s'arrête pas et note N/A jusqu'en colonne XFD...

Un dernier coup de pouce me serait très utile.

Merci

Poppy

Bonjour Poppy,

voici la modification, j'ai limité la copie au colonne A:V

Sub test()
With Sheets("Fichiers sources - tous projets")
rw = .Cells(Rows.Count, 1).End(xlUp).Row
col = .Cells(5, Columns.Count).End(xlToLeft).Column
Set Rng = .Range(Cells(6, 1).Address, Cells(rw, col).Address)
End With

rw2 = Sheets("Projets terminés").Cells(Rows.Count, 1).End(xlUp).Row + 1

x = Rng(1, 5)
For i = 1 To Rng.Rows.Count
    If Rng(i, 5) = "Terminé" Then
        Sheets("Projets terminés").Range("A" & rw2 & ":V" & rw2).Value = Rng.Rows(i).Value
        rw2 = Sheets("Projets terminés").Cells(Rows.Count, 1).End(xlUp).Row + 1
    End If
Next i
End Sub

Merci ! C'est parfait !

Excellente journée