ajouter date dans tous mes fichiers xls d'un même dossier

Le
magic-dd
bonjour, j'ai une macro qui ne fonctionne pas bien concernant la mise
à jour de date dans un de mes dossiers.

il est placé sur F:/FORMATION

Dans ce dossier, 35 fichiers xls

cela ne marche pas bien car il ne me le fait que sur 1 seul fichier

cerise sur le gateu , si je pouvais par un mpsgbox determiner le nom
du dossier que je souhaite exploiter cela serait superbe

genre :choisissez un mois puis apres indiquez la date.

merci

voici la commande

Sub test()
Dim inCalculationMode As Integer
Application.ScreenUpdating = False
inCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Dim Fich As String, Doss As Object, Parent As String
Dim FSO As Object, F As Object
Parent = "f:"

Var = InputBox("Entrez une date au format jj/mm/aaaa")

If IsDate(Var) Then
Var = CDate(Var)
End If

Set FSO = CreateObject("scripting.FileSystemObject")
1 For Each Doss In FSO.getfolder(Parent).subfolders
For Each F In Doss.Files
Fich = F.Path
If Fich <> "" Then
If LCase(Mid(Fich, InStrRev(Fich, ".") + 1, 3)) = "xls"
Then
Workbooks.Open Fich
Do
If Var > 0 Then
ActiveSheet.Range("b41").Value = Var

Exit Do
End If

Exit Sub

Loop
'Sheets("extraction").PrintOut
ActiveWorkbook.Close False

Exit For
End If
End If
Next
Application.Calculation = inCalculationMode
Application.Calculation = xlAutomatic
Next Doss
Application.Calculation = inCalculationMode
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichD
Le #24572211
Bonjour,

Essaie d'être plus précis.

Que veux-tu faire?

Quel est ton (tes) critère qui déterminera le fichier du répertoire mentionné sur lequel
tu veux travailler?



MichD
---------------------------------------------------------------
magic-dd
Le #24572271
On 18 juin, 14:49, "MichD"
Bonjour,

Essaie d' tre plus pr cis.

Que veux-tu faire?

Quel est ton (tes) crit re qui d terminera le fichier du r pertoire menti onn sur lequel
tu veux travailler?

MichD
---------------------------------------------------------------



bonjour MichD

mon premier criter est de determiner dans quel dossier la macro va
s'effecftuer ex choix du mois

je lui dis NOVEMBRE

ensuite lui indiquer la date à inscrire dans chaque fichier de ce
dossier NOVEMBRE

dans mon dossier NOVEMBRE, comme dans tous les autres des mois de
l'année, se trouvent des fichiers nommes 1.xls jusqu'à 35.xls

dans chacuns de ces fichiers, il faut qu'en B41 soit inscrit la date
inscrite plus tot dans la Box

en esperant avoir été plus clair

merci
magic-dd
Le #24572261
bonjour
le premier critere est le choix du dossier contenant mes fichiers
xls.

ex NOVEMBRE

le second est d'inscrire une date qui sera noté dans chacun de ces
fichiers xls

chaque dossier mensuel contient 35 fichiers xls nommés de 1.xls à
35.xls.

merci
------------------------------------
MichD
Le #24572491
Essaie ceci dans un module standard :


'----------------------------------------------------------------------
Sub test()
Dim Chemin As String, Message As String
Dim S As Variant
Dim LaDate As Variant, Année As String
Dim Jour As String, Mois As String, Rep As String
Dim Fichier As String, Wk As Workbook

Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Do
LaDate = Application.InputBox(Prompt:="Saisissez une date" & _
vbCrLf & vbCrLf & _
"Respectez le format date suivant : Jour/Mois/Année", _
Title:="Choix de la date...", Type:=2)
'Si l'usager annule...
If LaDate = False Then MsgBox "Opération annulée.": Exit Sub
'si la fenêtre se referme vide
If LaDate = "" Then MsgBox "Opération annulée.": Exit Sub
S = Split(LaDate, "/")
Jour = S(0)
Mois = S(1)
Année = S(2)
If IsDate(LaDate) Then
If CDate(LaDate) = DateSerial(Année, Mois, Jour) Then
ok = True
Else
MsgBox "problème avec la date saisie. Recommencer."
End If
Else
MsgBox "Le format demandé n'a pas été respecté. Recommencer."
End If
Loop Until ok = True

'Ce qui s'affichera dans la fenêtre
Message = "Sélectionner un des répertoires affichés"
'Répertoire de départ à l'ouverture de la fenêtre
'à toi de le définir si nécessaire...
Rep = Application.DefaultFilePath
's'assurer que l'on est sur le bon lecteur
ChDrive Left(Rep, 1)
Chemin = ChoixDossier(Rep)
If Chemin = "" Then
MsgBox "Vous avez annulé votre choix. Opération annulée"
End If

Fichier = Dir(Chemin & "" & "*.xl*")

Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & "" & Fichier)
With Wk.ActiveSheet.Range("B41")
If CLng(.Value) <> CLng(CDate(LaDate)) Then
.NumberFormat = "DD/MM/YY"
.Value = CLng(CDate(LaDate))
Wk.Close True
Else
Wk.Close
End If
End With
Fichier = Dir()
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'----------------------------------------------------------------------
Function ChoixDossier(Rep As String)
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & ""
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
End Function
'----------------------------------------------------------------------

MichD
---------------------------------------------------------------
MichD
Le #24572481
Correction dans la dernière section :

Utilise plutôt ceci :


Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & "" & Fichier)
With Wk.ActiveSheet.Range("B41")
If CLng(.Value) <> CLng(CDate(LaDate)) Then
.NumberFormat = "DD/MM/YY"
.Value = CLng(CDate(LaDate))
Wk.Close True
Else
Wk.Close False
End If
End With
Set Wk = Nothing
Fichier = Dir()
Loop




MichD
---------------------------------------------------------------
"MichD" a écrit dans le message de groupe de discussion :
jrnet4$seu$


Essaie ceci dans un module standard :


'----------------------------------------------------------------------
Sub test()
Dim Chemin As String, Message As String
Dim S As Variant
Dim LaDate As Variant, Année As String
Dim Jour As String, Mois As String, Rep As String
Dim Fichier As String, Wk As Workbook

Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Do
LaDate = Application.InputBox(Prompt:="Saisissez une date" & _
vbCrLf & vbCrLf & _
"Respectez le format date suivant : Jour/Mois/Année", _
Title:="Choix de la date...", Type:=2)
'Si l'usager annule...
If LaDate = False Then MsgBox "Opération annulée.": Exit Sub
'si la fenêtre se referme vide
If LaDate = "" Then MsgBox "Opération annulée.": Exit Sub
S = Split(LaDate, "/")
Jour = S(0)
Mois = S(1)
Année = S(2)
If IsDate(LaDate) Then
If CDate(LaDate) = DateSerial(Année, Mois, Jour) Then
ok = True
Else
MsgBox "problème avec la date saisie. Recommencer."
End If
Else
MsgBox "Le format demandé n'a pas été respecté. Recommencer."
End If
Loop Until ok = True

'Ce qui s'affichera dans la fenêtre
Message = "Sélectionner un des répertoires affichés"
'Répertoire de départ à l'ouverture de la fenêtre
'à toi de le définir si nécessaire...
Rep = Application.DefaultFilePath
's'assurer que l'on est sur le bon lecteur
ChDrive Left(Rep, 1)
Chemin = ChoixDossier(Rep)
If Chemin = "" Then
MsgBox "Vous avez annulé votre choix. Opération annulée"
End If

Fichier = Dir(Chemin & "" & "*.xl*")

Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & "" & Fichier)
With Wk.ActiveSheet.Range("B41")
If CLng(.Value) <> CLng(CDate(LaDate)) Then
.NumberFormat = "DD/MM/YY"
.Value = CLng(CDate(LaDate))
Wk.Close True
Else
Wk.Close
End If
End With
Fichier = Dir()
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'----------------------------------------------------------------------
Function ChoixDossier(Rep As String)
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & ""
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
End Function
'----------------------------------------------------------------------

MichD
---------------------------------------------------------------
Gloops
Le #24573101
magic-dd a écrit, le 18/06/2012 14:40 :
cerise sur le gateu , si je pouvais par un mpsgbox determiner le nom
du dossier que je souhaite exploiter cela serait superbe



Bonjour,

Pour choisir un répertoire, certes on peut utiliser InputBox à condit ion
que l'utilisateur ne se trompe pas sur l'orthographe du répertoire (et
des répertoires parents), mais on pourra être intéressé de regard er du
côté de Application.BrowseForFolder.

D'ailleurs, voilà quelqu'un qui trouve ça tellement pratique qu'il ou vre
carrément Excel pour le faire depuis une autre application :

http://www.vbaexpress.com/kb/getarticle.php?kb_id(4

Peut-être qu'il pousse un peu loin et qu'il se donnerait moins de mal e n
appelant une API, mais enfin c'est histoire de dire qu'Excel sait faire.
magic-dd
Le #24574901
On 18 juin, 16:47, "MichD"
Correction dans la derni re section :

Utilise plut t ceci :

Do While Fichier <> ""
    Set Wk = Workbooks.Open(Chemin & "" & Fichier)
    With Wk.ActiveSheet.Range("B41")
        If CLng(.Value) <> CLng(CDate(LaDate)) Then
            .NumberFormat = "DD/MM/YY"
            .Value = CLng(CDate(LaDate))
            Wk.Close True
        Else
            Wk.Close False
        End If
    End With
    Set Wk = Nothing
    Fichier = Dir()
Loop

MichD
---------------------------------------------------------------
"MichD"  a crit dans le message de groupe de discussion :
jrnet4$

Essaie ceci dans un module standard :

'----------------------------------------------------------------------
Sub test()
Dim Chemin As String, Message As String
Dim  S As Variant
Dim LaDate As Variant, Ann e As String
Dim Jour As String, Mois As String, Rep As String
Dim Fichier As String, Wk As Workbook

Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Do
    LaDate = Application.InputBox(Prompt:="Saisissez une date" & _
        vbCrLf & vbCrLf & _
        "Respectez le format date suivant : Jour/Mois/Ann e", _
        Title:="Choix de la date...", Type:=2)
    'Si l'usager annule...
    If LaDate = False Then MsgBox "Op ration annul e.": Exit Sub
    'si la fen tre se referme vide
    If LaDate = "" Then MsgBox "Op ration annul e.": Exit Sub
    S = Split(LaDate, "/")
    Jour = S(0)
    Mois = S(1)
    Ann e = S(2)
If IsDate(LaDate) Then
    If CDate(LaDate) = DateSerial(Ann e, Mois, Jour) Then
        ok = True
    Else
        MsgBox "probl me avec la date saisie. Recommencer."
    End If
Else
    MsgBox "Le format demand n'a pas t respect . Recommencer."
End If
Loop Until ok = True

'Ce qui s'affichera dans la fen tre
Message = "S lectionner un des r pertoires affich s"
'R pertoire de d part l'ouverture de la fen tre
' toi de le d finir si n cessaire...
Rep = Application.DefaultFilePath
's'assurer que l'on est sur le bon lecteur
ChDrive Left(Rep, 1)
Chemin = ChoixDossier(Rep)
If Chemin = "" Then
    MsgBox "Vous avez annul votre choix. Op ration annul e"
End If

Fichier = Dir(Chemin & "" & "*.xl*")

Do While Fichier <> ""
    Set Wk = Workbooks.Open(Chemin & "" & Fichier)
    With Wk.ActiveSheet.Range("B41")
        If CLng(.Value) <> CLng(CDate(LaDate)) Then
            .NumberFormat = "DD/MM/YY"
            .Value = CLng(CDate(LaDate))
            Wk.Close True
        Else
            Wk.Close
        End If
    End With
    Fichier = Dir()
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'----------------------------------------------------------------------
Function ChoixDossier(Rep As String)
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = ActiveWorkbook.Path & ""
      .Show
      If .SelectedItems.Count > 0 Then
         ChoixDossier = .SelectedItems(1)
      Else
         ChoixDossier = ""
      End If
    End With
End Function
'----------------------------------------------------------------------

MichD
---------------------------------------------------------------



merci michD

cela fonctionne au poil

mon seul hic car il en faut un est que mes fichiers ont tous des mots
de passes en ecriture differents.
donc ca merdouille il faut que je les tapes 1 par 1

est ce possible de pouvoir ecrire sans mettre de password?
MichD
Le #24574891
Si tu as mis des mots de passe pour ouvrir ton fichier, tu n'as pas le choix,
tu dois le fournir à la procédure pour que l'ouverture de ces fichiers
s'effectue normalement.

Tu pourrais dans le classeur où tu as mis cette procédure avoir un tableau sur
une feuille de calcul contenant une colonne contenant la liste des fichiers et
dans une autre colonne, les mots de passe pour chacun d'eux.

En utilisant une approche comme ceci :
x=Application.Match(NomduFichier,PlageNomFichier,0)
MotDePasse = Range("A" & x)

Et dans la ligne qui ouvre le fichier, tu ajoutes le paramètre "PassWord"

Set Wk = Workbooks.Open(Filename:=Chemin & "" & Fichier,PassWord:=MotDePasse)



MichD
---------------------------------------------------------------
magic-dd
Le #24575221
encore excellent michD

le mot de passe n'est qu'en ecriture donc le systeme de la feuille me
plait bien

j'ai essayé mais cela n'a pas l'air de fonctionner

tres certainement parce que les lignes ne sont pas au bon endroit

merci de ton aide
MichD
Le #24575591
Dans l'onglet de la Feuil1

Colonne A1:Ax -> Seulement les noms des fichiers + leurs extensions
Colonne B1:Bx -> Mot de passe associé à chaque classeur.

Tu peux modifier le nom de l'onglet dans la procédure
Et si tu veux rendre cette feuille invisible et inaccessible pour les usagers

Worksheets("Feuil1").Visible = xlSheetVeryHidden

Si une feuille n'a pas de mot de passe, il n'est pas traité et tu as un message
qui t'avertit que tel fichier n'a pas de mot de passe...

'---------------------------------------------------------------------------------------------
Sub test()
Dim Chemin As String, Message As String
Dim S As Variant, DerLig As Long, X As Variant
Dim LaDate As Variant, Année As String
Dim Jour As String, Mois As String, Rep As String
Dim Fichier As String, Wk As Workbook
Dim MotDePasse As String

Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Do
LaDate = Application.InputBox(Prompt:="Saisissez une date" & _
vbCrLf & vbCrLf & _
"Respectez le format date suivant : Jour/Mois/Année", _
Title:="Choix de la date...", Type:=2)
'Si l'usager annule...
If LaDate = False Then MsgBox "Opération annulée.": Exit Sub
'si la fenêtre se referme vide
If LaDate = "" Then MsgBox "Opération annulée.": Exit Sub
S = Split(LaDate, "/")
Jour = S(0)
Mois = S(1)
Année = S(2)
If IsDate(LaDate) Then
If CDate(LaDate) = DateSerial(Année, Mois, Jour) Then
ok = True
Else
MsgBox "problème avec la date saisie. Recommencer."
End If
Else
MsgBox "Le format demandé n'a pas été respecté. Recommencer."
End If
Loop Until ok = True

'Ce qui s'affichera dans la fenêtre
Message = "Sélectionner un des répertoires affichés"
'Répertoire de départ à l'ouverture de la fenêtre
'à toi de le définir si nécessaire...
Rep = Application.DefaultFilePath
's'assurer que l'on est sur le bon lecteur
ChDrive Left(Rep, 1)
Chemin = ChoixDossier(Rep)
If Chemin = "" Then
MsgBox "Vous avez annulé votre choix. Opération annulée"
End If

Fichier = Dir(Chemin & "" & "*.xl*")

Do While Fichier <> ""
With Worksheets("Feuil1")
DerLig = .Range("A65536").End(xlUp).Row
X = Application.Match(Fichier, .Range("A" & DerLig), 0)
If IsNumeric(X) Then
MotDePasse = .Range("B" & DerLig)
Set Wk = Workbooks.Open(Filename:=Chemin & "" & Fichier,
Password:=MotDePasse)
With Wk.ActiveSheet.Range("B41")
If CLng(.Value) <> CLng(CDate(LaDate)) Then
.NumberFormat = "DD/MM/YY"
.Value = CLng(CDate(LaDate))
Wk.Close True
Else
Wk.Close False
End If
End With
Set Wk = Nothing
Else
Err = 0
MsgBox "Pas trouvé de mot de passe pour le fichier " & _
"""" & Fichier & """."
End If
Fichier = Dir()
End With
Loop

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'----------------------------------------------------------------------
Function ChoixDossier(Rep As String)
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & ""
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
End Function
'----------------------------------------------------------------------







MichD
---------------------------------------------------------------
"magic-dd" a écrit dans le message de groupe de discussion :


encore excellent michD

le mot de passe n'est qu'en ecriture donc le systeme de la feuille me
plait bien

j'ai essayé mais cela n'a pas l'air de fonctionner

tres certainement parce que les lignes ne sont pas au bon endroit

merci de ton aide
Publicité
Poster une réponse
Anonyme