Copier des données sous conditions d'une colonne à l'autre VBA

Bonjour chère communauté :)

Je souris mais en vérité j'ai passé de 9h30 du matin jusqu'à maintenant pour résoudre ce problème :(.

Voici une capture d'écran simplifiée (illustratif) du sujet :

Je m'explique : à chaque fois où une date se rajoute à la suite dans la colonne A (provenant d'un userform), Si elle est supérieure à la date d'aujourd'hui (D1) et si elle n'existe pas dans la colonne H, alors elle se rajoute à la suite dans H, sinon rien ne se passe.

Voici le code qui m'a permis d'atteindre ce résultat (j'ai tant mouliné !) : problème : la date 31/07/2022 s'est refaite ...

Sub CopierDateSupToday()

Dim Lig4 As Integer, Lig2 As Integer
With Sheets("Feuil3")
Lig4 = .Range("A" & Rows.Count).End(xlUp).Row
For Lig2 = 1 To .Range("H" & Rows.Count).End(xlUp).Row
If .Cells(Lig4, 1) > .Cells(1, 4) And .Cells(Lig2 + 1, 8) = "" And .Cells(Lig4, 1) <> .Cells(Lig2, 8) Then
.Cells(Lig4, 1).Copy
.Cells(Lig2 + 1, 8).PasteSpecial Paste:=xlPasteValues
End If
Next Lig2
End With
End Sub

Merci de me dépanner les amis :)

Essaie ca, en fait ta condition est fausse :.Cells(Lig4, 1) <> .Cells(Lig2, 8) : ce sera forcément différent à un moment vu qu'il passe sur toutes les dates de la colonne H.

Sinon tu mets un compteur à 0 et tu passes sur tous les éléments de la colonne H et si jamais ta date existe pas tu fais rien et si elle existe tu incrémentes ton compteur de 1. Et la tu rajoutes dans ton test : SI (compteur <>1) alors tu copies

Tu vois ce que je veux dire ?

Bonjour,

Une variante :

Sub CopierDateSupToday()
Dim MaDate As Long
With Sheets("Feuil3")
    MaDate = .Cells(Rows.Count, "A").End(xlUp)
    If MaDate > .Range("D1") And IsError(Application.Match(MaDate, .Columns(8), 0)) Then
        .Cells(Rows.Count, "H").End(xlUp)(2) = CDate(MaDate)
    End If
End With
End Sub

Bon courage

Bonjour Batoute78

Merci pour votre réponse :)

Ça sea mieux si vous m'écrivez le code svp car je ne connais pas où placer justement le bloc dont vous parlez (j'ai seulement 2 mois d'expérience en vba)... merci beaucoup

Hello

A tester :

Sub CopierDateSupToday()

Dim Lig4 As Integer, Lig2 As Integer
With Sheets("Feuil3")
Lig4 = .Range("A" & Rows.Count).End(xlUp).Row

compteur = 0
For LigDateSup = 2 to .Range("H" & Rows.Count).End(xlUp).Row
If .Range("H" & LigDateSup) = .Range("A" & Lig4) then compteur = compteur +1
Next LigDateSup

For Lig2 = 1 To .Range("H" & Rows.Count).End(xlUp).Row
If .Cells(Lig4, 1) > .Cells(1, 4) And .Cells(Lig2 + 1, 8) = "" And compteur = 0 Then
.Cells(Lig4, 1).Copy
.Cells(Lig2 + 1, 8).PasteSpecial Paste:=xlPasteValues
End If
Next Lig2
End With
End Sub

@+

Merci baroute78 et cousinhb29 toutes les deux solutions marchent :)