Fonction archivage problème de critère

rkan

XLDnaute Nouveau
Bonjour,

Je suis actuellement sur une fonction d'archivage de données dont voici une partie du code :

Code:
Sub Suppression_trié_PT()

    Dim Rw As Range
    Dim Ligne As Long
    
    ActiveSheet.Select
    ActiveCell.SpecialCells(xlLastCell).Select
    Range(Selection, Cells(3, 1)).Select

    For Each Rw In Selection.Rows
       Ligne = Rw.Row
        If Rw.Cells(28).Text Like "*Affaire terminée*" And Rw.Cells(8).Value <= Reponse1 Then
            Rw.Cut Destination:=Worksheets("ARCHIVE TMP").Cells(Ligne, 1)
        End If
    Next Rw
...

J'archive en fonction de 2 critères :

1) l'affaire doit apparaître comme terminée en colonne 28
2) la date de fin de l'affaire en colonne 8 doit être inférieure ou égale à celle récupérée en inputbox

Le problème dans mon fichier d'archive est que je récupère des affaires dont la date est supérieure à celle entrée en inputbox alors que je demande bien
Code:
Rw.Cells(8).Value <= Reponse1

Merci d'avance pour vos réponses.

pour info :

- Je suis débutant en VBA, je bricole en essayant de comprendre ce que je fais

- voilà mon code de récupération de date :

Code:
Sub SelectionOnglet_prArchivage()
    Dim Sh As Worksheet

    Reponse1 = InputBox("Veuillez préciser la date d'archivage voulue en respectant le format JJ/MM/AAAA : ")

        If Reponse1 = Empty Then
            MsgBox ("Veuillez enter une date valide !")
            Reponse1 = InputBox("entrer date")
        End If
        If Not IsDate(Reponse1) Then
            MsgBox ("Veuillez enter une date valide !")
            Reponse1 = InputBox("entrer date")
        End If
        If CDate(Reponse1) > Date Then
            MsgBox "La date doit être inférieure à la date d'aujourd'hui !"
            Reponse1 = InputBox("entrer date")
        End If

    For Each Sh In Worksheets
        If Left(UCase(Sh.Name), 4) = "GST_" Then
            Sh.Activate
            Suppression_trié_PT
            MsgBox "Archivage " & ActiveSheet.Name, vbExclamation + vbOKOnly, "**** MESSAGE IMPORTANT ****"
        End If
    Next Sh

End Sub

>>>MAJ :

J'ai modifié le code en remplaçant

Code:
Rw.Cells(8).Value <= Reponse1

par

Code:
Rw.Cells(8).Text like Reponse1

Dans ce cas la fonction archivage fait son travail sur la base d'une seule date, je ne vois toujours pas comment archiver sur une plage de dates.
 
Dernière édition:

Statistiques des forums

Discussions
312 563
Messages
2 089 692
Membres
104 257
dernier inscrit
Stane78