Fonctionnement code
Bonjour j arrive pas a le faire fontionnner bonne journée
Sub CopierSelonCondition()
Dim ws1 As Worksheet ' Feuille source (Feuil1)
Dim ws4 As Worksheet ' Feuille destination pour '4' (Feuil4)
Dim ws5 As Worksheet ' Feuille destination pour '5' (Feuil5)
Dim Plage As Range ' Plage C2:G2
Dim Cell As Range ' Cellule individuelle
Dim LigneDest As Long ' Pour trouver la prochaine ligne vide
' 1. Définir les feuilles
Set ws1 = ThisWorkbook.Sheets("Feuil1")
Set ws4 = ThisWorkbook.Sheets("Feuil4")
Set ws5 = ThisWorkbook.Sheets("Feuil5")
' 2. Définir la plage à vérifier (C2:G2)
Set Plage = ws1.Range("C2:G2")
' 3. Boucle sur chaque cellule de la plage C2:G2
For Each Cell In Plage
If Cell.Value = 5 Then
' Si la valeur est 5
ws1.Range("A2:G2").Copy ' Copier toute la ligne A2:G2
ws5.Activate ' Activer la Feuil5
' Trouver la première ligne vide dans la colonne A de Feuil5
LigneDest = ws5.Cells(Rows.Count, "A").End(xlUp).Row + 1
ws5.Cells(LigneDest, "A").PasteSpecial Paste:=xlPasteValues ' Coller les valeurs (ou xlPasteAll pour tout)
Application.CutCopyMode = False ' Désactiver le mode copier/coller
Exit For ' Sortir de la boucle une fois trouvé (si plusieurs 5, la première suffit)
ElseIf Cell.Value = 4 Then
' Si la valeur est 4
ws1.Range("A2:G2").Copy ' Copier toute la ligne A2:G2
ws4.Activate ' Activer la Feuil4
' Trouver la première ligne vide dans la colonne A de Feuil4
LigneDest = ws4.Cells(Rows.Count, "A").End(xlUp).Row + 1
ws4.Cells(LigneDest, "A").PasteSpecial Paste:=xlPasteValues ' Coller les valeurs
Application.CutCopyMode = False ' Désactiver le mode copier/coller
Exit For ' Sortir de la boucle
End If
Next Cell
End SubEdit modo : merci d'utiliser les balises de code lorsque vous postez un code. cela sera plus lisible pour celui qui vous répond
Bonjour,
Option Explicit
Sub CopierSelonCondition()
Dim Ws1 As Worksheet, Ws4 As Worksheet, Ws5 As Worksheet
Dim Plage As Range, LaCellule As Range
' 1. Définir les feuilles
Set Ws1 = Sheets("Feuil1"): Set Ws4 = Sheets("Feuil4"): Set Ws5 = Sheets("Feuil5")
' 2. Définir la plage à vérifier (C2:G2)
Set Plage = Ws1.Range("C2:G2")
' 3. Boucle sur chaque cellule de la plage C2:G2
For Each LaCellule In Plage
Select Case LaCellule
Case 5
CollerDansOnglet Ws5, Plage
Exit For ' Sortir de la boucle une fois trouvé (si plusieurs 5, la première suffit)
Case 4
CollerDansOnglet Ws4, Plage
Exit For
End Select
Next LaCellule
Set Ws1 = Nothing: Set Ws4 = Nothing: Set Ws5 = Nothing: Set Plage = Nothing
End Sub
Sub CollerDansOnglet(ByVal ShDest As Worksheet, ByVal AireAColler As Range)
Dim LigneDest As Long
AireAColler.Copy
With ShDest
LigneDest = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(LigneDest, "A").PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
End Subbonjour j envoie mon fichier car jaimerais metre les dates merci d avoir regarder quand je fait le tien voila ce qui ce passe bonne journée luc
Il faudrait préciser la règle de gestion si la plage contient des 4 et des 5 car tel que vous l'avez écrit dans votre code, le 4 étant avant le 5, c'est l'onglet Ws4 qui va être alimenté.
Faut-il vérifier d'abord la présence du 5 d'abord et alimenter Ws5 ? Et si pas de 5 vérifier la présence d'un 4 ?
Quelle est l'utilité de tester une seule ligne dans Ws1 ?
Bonjour
1)oui on peut faire les 10 première ligne à partir de a2
2)si on calcul les 10 premier il aura plusieurs lignes qui devais aller dans la feuille 4
3)s’il y a dans (c2 : l10) il y a 5 et 4 il doit aller les deux dans la feuille 4 et la feuille 5 si pas le nombre il ne faut rien faire
4)quand on doit copier la feuille 1 ces avec la date et la Cologne b PV
Oui j’ai plus 100 feuilles c’est pour sa je fais un teste et puis je devrais travailler en ajoutent
bien a vous luc bonne soirée
Mais pourquoi seulement 10 ?
Ce serait plus simple de mettre en ligne un fichier avec des cas concrets et les résultats attendus plutôt que de jouer aux devinettes.
merci pour ton aide je me debrouilerais bonne soirée
Sub CopierSelonCondition()
Dim Valeur4Trouvee As Boolean, Valeur5Trouvee As Boolean
Dim I As Long, J As Long, DerniereColonne As Long, DerniereLigne As Long
Dim Ws1 As Worksheet, Ws4 As Worksheet, Ws5 As Worksheet
Dim PlageACopier As Range, PlageATester As Range
Set Ws1 = Sheets("Feuil1"): Set Ws4 = Sheets("Feuil4"): Set Ws5 = Sheets("Feuil5")
With Ws1
DerniereColonne = .Cells(1, .Columns.Count).End(xlToLeft).Column
DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
Set PlageATester = .Range(.Cells(1, 2), .Cells(DerniereLigne, 1))
For I = 1 To PlageATester.Count
Set PlageACopier = .Range(.Cells(I, 1), .Cells(I, DerniereColonne))
Valeur4Trouvee = False: Valeur5Trouvee = False
For J = 3 To 8
Select Case PlageACopier(J)
Case 5
If Valeur5Trouvee = False Then
CollerDansOnglet Ws5, PlageACopier
Valeur5Trouvee = True
End If
Case 4
If Valeur4Trouvee = False Then
CollerDansOnglet Ws4, PlageACopier
Valeur4Trouvee = True
End If
End Select
Next J
Next I
End With
Ws4.Columns(1).NumberFormat = "dddd dd mmmm yyyy"
Ws5.Columns(1).NumberFormat = "dddd dd mmmm yyyy"
Set Ws1 = Nothing: Set Ws4 = Nothing: Set Ws5 = Nothing
Set PlageACopier = Nothing: Set PlageATester = Nothing
End Sub
Sub CollerDansOnglet(ByVal ShDest As Worksheet, ByVal AireAColler As Range)
Dim LigneDest As Long
AireAColler.Copy
With ShDest
LigneDest = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(LigneDest, "A").PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
End Submerci ces bien cela ces gentil bonne soirée
pour la formule Set Ws1 = Sheets("TR")
Set Ws4 = Sheets("N4")
Set Ws5 = Sheets("N5")
jais 124 feuille je dois matre 124 x chaque formule ?
merci j avais plus de 7500 lignes et il es a caluler tous