VBA copie si dans période saisie pb date

Question

Bonjour tout le monde,

Je suis nouveau dans l'utilisation de vba, et la malgré mes recherches un peu partout je ne trouve pas de solution.

Voila j'ai fait une macro pour copier dans un fichier "analyse_jour" des infos d'un autre fichier "MPOU" en fonction de la date saisie. 
Pour faire cela, j'ai un peu "bricolé" et je me trouve maintenant confronté à 2 problèmes.

  Sub analyse_jour()

Dim Cel As Range
Dim Mot As String
Dim R As Range


Windows("Analyse MPOU.xls").Activate
    Sheets("Analyse_jour").Activate
        Rows("3:3").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Delete Shift:=xlUp

Set R = Sheets("Analyse_jour").Range("A3")
Windows("fichier suivi MPOU ML1.xls").Activate
Sheets("MPOU").Activate
Mot = InputBox("Saisissez le jour à analyser (jj/mm/aaaa)")
If Mot = "" Then
Exit Sub
    Else
    For Each Cel In ActiveSheet.UsedRange
        If UCase(Cel) = UCase(Mot) Then
        Cel.EntireRow.Copy R
        Set R = R.Offset(1)
        End If
Next Cel
Application.CutCopyMode = False
Windows("Analyse MPOU.xls").Activate
Sheets("Analyse_jour").Select
End If

End sub

1°_ Je voudrais que si ce qui est saisi dans l'input box n'est pas de format jj/mm/aaaa un msgbox marque quelque chose du genre "erreur de saisie, veuillez recommencez". (en remplacement du "If Mot = "" Then Exit Sub" que j'ai pour le moment.

2°_ Maintenant que j'arrive à sélectionne une date, je voudrais pouvoir sélectionner une période. J'ai essayé avec 

Mot = InputBox("Saisissez la date de début (jj/mm/aaaa)")
Mot1 = InputBox("Saisissez la date de fin (jj/mm/aaaa)")
If Mot = "" Then
Elseif Mot1 = "" then
Exit Sub
    Else
    For Each Cel In ActiveSheet.UsedRange
        If UCase(Cel) >= UCase(Mot) Then
         Elseif UCase(Cel) <= UCase(Mot1) Then
        Cel.EntireRow.Copy R
        Set R = R.Offset(1)
        End If

Mais ça ne fonctionne pas j'ai tout et n'importe quoi qui est alors copier et collé dans la feuille "analyse_jour".

Donc voila si quelqu'un peut m'aider ce serait gentil, car je suis à la limite de ce que je peux faire tout seul!

Merci par avance pour votre aide, et bonne après midi!

michel_m · Answer

Bonjour

ci dessous exemple de procédure pour vérifier la syntaxe de la date début et fin

Public date_deb As Date, fin As Date

Sub test()
verif_date "debut"
verif_date "fin"
End Sub

Sub verif_date(entree As String)
Dim flag As Boolean, saisie As String
While flag = False
    saisie = Application.InputBox("date " & entree & " ?", Default:="00/00/00")
    If saisie Like "##[/]##[/]##" Then
        If entree = "debut" Then
            date_deb = CDate(saisie)
        Else
            date_fin = CDate(saisie)
        End If
        flag = True
    Else
        MsgBox "erreur saisie", vbCritical
    End If
Wend
End Sub

bruno · Answer

Bonjour,

Déja merci beaucoup pour votre aide!

Je viens d'essayer la macro et cela marche c'est exactement ce qu'il me fallait.

Par contre je n'arrive pas à l'insérer dans ma macro car il s'agit déja de 2 macros donc je ne vois pas ou les mettre!

Je vous met ma macro en entier, pouvez vous m'aider?

Merci encore

Sub analyse_jour()

Dim Cel As Range
Dim Mot As String
Dim R As Range


Windows("Analyse MPOU.xls").Activate
    Sheets("Analyse_jour").Activate
        Rows("3:3").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Delete Shift:=xlUp

Set R = Sheets("Analyse_jour").Range("A3")
Windows("fichier suivi MPOU ML1.xls").Activate
Sheets("MPOU").Activate
Mot = InputBox("Saisissez le jour à analyser (jj/mm/aaaa)")
If Mot = "" Then
Exit Sub
Else
For Each Cel In ActiveSheet.UsedRange
If UCase(Cel) = UCase(Mot) Then
Cel.EntireRow.Copy R
Set R = R.Offset(1)
End If
Next Cel
Application.CutCopyMode = False
Windows("Analyse MPOU.xls").Activate
Sheets("Analyse_jour").Select
End If

bruno · Answer

Re,

En fait à la base j'utilisais

<> For Each Cel In ActiveSheet.UsedRange
If UCase(Cel) = UCase(Mot) Then
Cel.EntireRow.Copy R </>

Cela ne prenais (je crois) pas en compte le format date mais me disais juste si la valeur était égale à la valeur saisie. Du coup ça marche bien pour sélectionner un seul jour.

Par contre comme maintenant je veux un intervalle cela ne fonctionne plus. Et le fait de mettre <= et >= avec elseif, effectivement, me fait copier plusieurs fois la même ligne! Mais je ne sais pas ce que je dois utiliser dans ce cas là...

Je vous joins les 2 fichiers que j'utilise.

http://www.cijoint.fr/cjlink.php?file=cj201007/cij09gOYnL.xls
http://www.cijoint.fr/cjlink.php?file=cj201007/cijC7PU1sM.xls

Voila merci encore

bruno · Answer

Bonjour,

J'ai eu quelques soucis ces 2 derniers jours je n'ai pas pu me pencher avant sur la macro...
Voila donc j'ai essayé dans le fichier cela donne :

1°_ erreur 438 propriété ou methode non gérée par cette objet : cela passe si à la place de
<>
Windows("Analyse MPOU.xls").Sheets("Analyse_jour").Activate
</>
je met
<>
Windows("Analyse MPOU.xls").Activate
Sheets("Analyse_jour").Activate
</>

2°_erreur 91 variable objet ou variable de bloc with non définie sur la ligne
<>
lig_deb = Columns(1).Find(date_deb, Range("A2")).Row
</>
La par contre je seche...

Sinon pour la saisie des dates et le message d'erreur ça marche bien.

Voila si vous pouvez encore m'aider :)

Bonne apres midi

bruno · Answer

Re bonjour,

J'ai effacé tout le reste pour ne mettre que cette macro mais ça ne fonctionne toujours pas...

J'ai en effet toujours les 2 erreurs citées ci dessus.

Merci pour votre aide mais la je bloque toujours.

Bonne soirée

bruno · Answer

Re bonjour,

Après une ou deux modifs ça fonctionne sauf lorsque je met une date ou il n'y a pas de saisie : exemple si je met en date de fin le 17/07/2010 ou il n'y a pas d'entrée la macro copie les ligne jusqu'à la fin du tableau.
Est il possible de rajouter dans la vérif que la date d'entrée contient bien des données, et sinon message d'erreur "pas d'entrée. Veuillez recommencer?

Sinon encore une fois merci pour votre aide précieuse...

<a>
Sub analyser_période()
Dim lig_deb As Integer, lig_fin As Integer
Dim tablo

'------COLLECTE
Windows("fichier suivi MPOU ML1.xls").Activate
Sheets("MPOU").Activate

'demande à l'utilisateur les journées à copier
date_deb = verif_date("premier jour")
date_fin = verif_date("dernier jour")

'détermine la zone à copier
lig_deb = Columns(1).Find(date_deb, Range("A2")).Row
'prend en compte si le le jour après le dernier jour n'est pas le dernier dans la colonneA
If Application.CountIf(Columns(1), date_fin + 1) = 0 Then
lig_fin = Range("A1684").End(xlUp).Row
Else
lig_fin = Columns(1).Find(date_fin + 1, Range("A2")).Row - 1
End If
'ensemble à copier
tablo = Range(Cells(lig_deb, 1), Cells(lig_fin, 17))

'------ RESTITUTION
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Analyse").Activate
'nettoie le tableau
Range("A3:Q" & Range("A1000").End(xlUp).Row).Clear
'effectue la copie
Range("A3").Resize(UBound(tablo), 17) = tablo
'met en forme
With Range("A3").CurrentRegion
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter

End With

End Sub

Function verif_date(entree As String) As Date
Dim flag As Boolean, saisie As String
While flag = False
saisie = Application.InputBox("date " & entree & " ?", Default:="jj/mm/aaaa")
On Error GoTo erreur
verif_date = CDate(saisie)
If CStr(CDate(saisie)) <> saisie Then GoTo erreur
flag = True
Exit Function
erreur:
MsgBox "erreur saisie", vbCritical
Wend

End Function
<\>

bruno · Answer

Bonjour,

Toujours moi pour mon problème par rapport à la saisie d'une date qui ne comporte pas d'entrée : je voudrais que tant que date_deb ne comporte pas d'entrée alors date_deb = date_deb+1 et tant que date_fin ne comporte pas d'entrée alors date_fin=date_fin-1.

Quelqu'un peut il m'aider?

Au passage je remet la macro "final" qui prend en compte les données de 3 fichier.

Merci pour votre aide


Sub analyser_TTX()
Dim lig_deb As Integer, lig_fin As Integer
Dim tablo

'------COLLECTE SUB ENGINE
Windows("fichier suivi MPOU Sub engine.xls").Activate
Sheets("MPOU").Activate

'demande à l'utilisateur les journées à copier
date_deb = verif_date("premier jour")
date_fin = verif_date("dernier jour")

'détermine la zone à copier
lig_deb = Columns(1).Find(date_deb, Range("A2")).Row
'prend en compte si le le jour après le dernier jour n'est pas le dernier dans la colonneA
If Application.CountIf(Columns(1), date_fin + 1) = 0 Then
lig_fin = Range("A1684").End(xlUp).Row
Else
lig_fin = Columns(1).Find(date_fin + 1, Range("A2")).Row - 1
End If
'ensemble à copier
tablo = Range(Cells(lig_deb, 1), Cells(lig_fin, 17))

'------ RESTITUTION
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Analyse").Activate
'nettoie le tableau
Range("A3:Q" & Range("A1000").End(xlUp).Row).Clear
'effectue la copie
Range("A3").Resize(UBound(tablo), 17) = tablo


'------COLLECTE ML1
Windows("fichier suivi MPOU ML1.xls").Activate
Sheets("MPOU").Activate


'détermine la zone à copier
lig_deb = Columns(1).Find(date_deb, Range("A2")).Row
'prend en compte si le le jour après le dernier jour n'est pas le dernier dans la colonneA
If Application.CountIf(Columns(1), date_fin + 1) = 0 Then
lig_fin = Range("A1684").End(xlUp).Row
Else
lig_fin = Columns(1).Find(date_fin + 1, Range("A2")).Row - 1
End If
'ensemble à copier
tablo = Range(Cells(lig_deb, 1), Cells(lig_fin, 17))

'------ RESTITUTION
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Analyse").Activate

'effectue la copie
Range("A3").End(xlDown).Offset(1, 0).Resize(UBound(tablo), 17) = tablo


'------COLLECTE ML2
Windows("fichier suivi MPOU ML2.xls").Activate
Sheets("MPOU").Activate


'détermine la zone à copier
lig_deb = Columns(1).Find(date_deb, Range("A2")).Row
'prend en compte si le le jour après le dernier jour n'est pas le dernier dans la colonneA
If Application.CountIf(Columns(1), date_fin + 1) = 0 Then
lig_fin = Range("A1684").End(xlUp).Row
Else
lig_fin = Columns(1).Find(date_fin + 1, Range("A2")).Row - 1
End If
'ensemble à copier
tablo = Range(Cells(lig_deb, 1), Cells(lig_fin, 17))

'------ RESTITUTION
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Analyse").Activate

'effectue la copie
Range("A3").End(xlDown).Offset(1, 0).Resize(UBound(tablo), 17) = tablo

'met en forme
With Range("A3").CurrentRegion
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With

Range("A3").Select

End Sub

VBA copie si dans période saisie pb date

7 réponses

Discussions similaires

Newsletters