VBA copie si dans période saisie pb date

bruno -
bruno - 29 juil. 2010 à 11:55

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!

A voir également:

VBA copie si dans période saisie pb date
Copie cachée - Guide
Copie écran samsung - Guide
Copie disque dur - Guide
Copie rapide - Télécharger - Gestion de fichiers
Saisie vocale whatsapp - Accueil - Messagerie instantanée

7 réponses

Réponse 1 / 7

michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention 3 313

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

michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention 3 313

re,

nouvelle avec utilisation d'une fonction (+ rationnel)

Sub test()
 date_deb = verif_date("debut")
date_fin = verif_date("fin")
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:="00/00/00")
    If saisie Like "##[/]##[/]##" Then
        flag = True
    Else
        MsgBox "erreur saisie", vbCritical
    End If
Wend
verif_date = CDate(saisie)
End Function

mais je n'ai pas compris dans ton code:

UCase(Cel) >= UCase(Mot)

a quoi set Ucase ? tes dates sont normalement au format date-nombre et non en string....

d'autre part avec:

For Each Cel In ActiveSheet.UsedRange
If UCase(Cel) >= UCase(Mot) Then
Elseif UCase(Cel) <= UCase(Mot1) Then ' ya un truc!
Cel.EntireRow.Copy R
Set R = R.Offset(1)
End If

Ne risque tu pas de recopier plusieurs fois la m^me ligne ?

au besoin joins des extraits de es 2 classeurs sur
http://cijoint.fr/
et colles le lien proposé dans ton message

merci de mettre tes codes entre les balises onglet <> en haut des zones de message CCm

Réponse 2 / 7

bruno

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

Réponse 3 / 7

bruno

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

michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention 3 313

Bonjour,

Ci dessous macros proposées

Sub analyser_journees() 
Dim lig_deb As Integer, lig_fin As Integer 
Dim tablo 

'------COLLECTE 
Windows("Analyse MPOU.xls").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_jour").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
    .FontStyle = "Normal"
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:="00/00/0000") 
    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

autre chose: les macros se déclenchant à l'ouverture du classeur doivent être écrites dans le module thisworkbook (workbook_open) et non par auto_open (XL>97?)

ci joint maquette
http://www.cijoint.fr/cjlink.php?file=cj201007/cijIpMtikp.xls

tu dis..

cordialement
Michel

edit 10:29: modifié mise en forme tableau restitution (non modifié sur maquette ci jointe)

michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention 3 313

lundi midi:
Merci: très sympa le coucou de remerciement de ta part! :-((

Réponse 4 / 7

bruno

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

michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention 3 313

lig_deb = Columns(1).Find(date_deb, Range("A2")).Row

chez moi ca marche, donc...

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 7

bruno

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

Réponse 6 / 7

bruno

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
<\>

Réponse 7 / 7

bruno

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

Discussions similaires

Copier un lien instagram

Retrouver liens copiés sur le téléphone

copie d'un lien dans le navigateur internet

lien copié presse papier smartphone Samsung

Votre réponse

Discussions similaires