Enregistrement d'un fichier en VBA

**Nausiboy** · 19/07/2023, 12h08

Bonjour,

J'ai un problème avec l'enregistrement des fichiers.
En faite j'enregistre mes fichier au format <ID "demande d'achat" émetteur fournisseur date du jour>
J'aimerais que l'ID s’incrémente a chaque nouvel enregistrement pour que les noms ce suivent.
Pour ce faire je test si le fichier existe déjà dans le répertoire ou se situe les fichiers.
Le problème c'est que cela marche que si j’enregistre plusieurs fichier le même jours car si je le fait a une autre date le fichier prend l ID 0 comme la date a change et qu'il pense que le fichier n'existe pas.
Peut t-on tester juste le début du nom d'un fichier ?
Y-a-t-il une autre solution ?

Merci d'avance !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
Sub DEMANDE_DE_VALIDATION_CHEF_DE_SERVICE()
 
 
'declaration des variables'
Dim ID As Integer
Dim Fichier_existe As String
Dim NomDossier As String
Dim NomFichier As String
Dim NomFournisseur As String
Dim FichierAtester As String
Dim Emetteur As String
Dim Adresse_emetteur As String
Dim Adresse_recepteur As String
Dim Date_DA As String
 
 
ActiveSheet.Unprotect Password:="CIA"
 
 
'Recuperation de l'emetteur'
Adresse_emetteur = Application.UserName
Range("Z24").Value = Range("D3").Value
Date_DA = Range("Z24").Value
 
 
' Recuperation des infos du fichier parametre '
 
' MAINTENANCE'
If Range("D4").Value = "MAINT" Then
 NomDossier = Range("AE11")
 Adresse_recepteur = Range("Z11")
 
'GP'
ElseIf Range("D4").Value = "GP" Then
 NomDossier = Range("AE12")
 Adresse_recepteur = Range("Z12")
 
 'QUALITE'
ElseIf Range("D4").Value = "QUALITE" Then
 NomDossier = Range("AE13")
 Adresse_recepteur = Range("Z13")
 
 'RH'
ElseIf Range("D4").Value = "RH" Then
 NomDossier = Range("AE15")
 Adresse_recepteur = Range("Z15")
 
 'PROD B21'
ElseIf Range("D4").Value = "PROD B21" Then
 NomDossier = Range("AE14")
 Adresse_recepteur = Range("Z14")
 
'V-LOG'
ElseIf Range("D4").Value = "V-LOG" Then
 NomDossier = Range("AE16")
 Adresse_recepteur = Range("Z16")
 
 'IT'
ElseIf Range("D4").Value = "IT" Then
 NomDossier = Range("AE17")
 Adresse_recepteur = Range("Z17")
 
  'PROD B41'
ElseIf Range("D4").Value = "PROD B41" Then
 NomDossier = Range("AE18")
 Adresse_recepteur = Range("Z18")
 
End If
 
'CREATION DU NOM DU FICHIER'
NomFournisseur = Range("G5").Value
Emetteur = Range("D5").Value
NomFichier = ID & " " & "Demande d'achat_" & NomFournisseur & "_" & Emetteur & "_" & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ".xlsm"
FichierAtester = NomDossier & ID & " " & "Demande d'achat_" & NomFournisseur & "_" & Emetteur & "_" & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ".xlsm"
 
'TEST SI LE FICHIER EXISTE'
Fichier_existe = Dir(FichierAtester)
 
While Fichier_existe <> ""
    ID = ID + 1
    FichierAtester = NomDossier & ID & " " & "Demande d'achat_" & NomFournisseur & "_" & Emetteur & "_" & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ".xlsm"
    NomFichier = ID & " " & "Demande d'achat_" & NomFournisseur & "_" & Emetteur & "_" & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ".xlsm"
    Fichier_existe = Dir(FichierAtester)
Wend
 
If Fichier_existe = "" And Range("D4").Value <> "" And Range("D5").Value <> "" And Range("G5").Value <> "" Then
    On Error Resume Next
 
    ' Creation de l'adresse mail de l'emetteur'
    Adresse_emetteur = Replace(Adresse_emetteur, " ", ".")
    Range("X1").Value = Adresse_emetteur & "@velux.com"
 
    'actualisation du statut'
    Range("J5").Value = ID
    Range("M31").Interior.ColorIndex = 46
    Range("D3").Value = Date_DA
 
 
    'Envoie par mail au chef de service'
    ThisWorkbook.SendMail Adresse_recepteur, "Demande d'achat"
 
    'eregistrement d'une copie dans le repertoire'
    ActiveWorkbook.SaveCopyAs NomDossier & NomFichier
 
    Range("D4:D5").Value = ""
    Range("G5").Value = ""
    Range("B7:J46").Value = ""
 
 
Else
MsgBox ("Erreur : Service, Emetteur ou Fournisseur inconnu ")
End If
ActiveSheet.Protect Password:="CIA"
End Sub

**Franc** · 19/07/2023, 12h29

Salut, teste comme ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Dim Fichier_existe As String
Fichier_existe = Dir("ID*")

**fraflt69** · 19/07/2023, 15h51

Bonjour Nausiboy

Comme ID est un integer, je te suggère de le formater sur 6 Caractères, avec Format(ID,"000000"), il sera plus facile de trouver le compteur le plus haut, il faudra faire minima une boucle, peut-être avec une expression régulière.

**Nausiboy** · 19/07/2023, 16h04

Merci Franc !
Merci Fraflt69 !

J'ai tester dir("ID*") mais malheureusement cela ne fonctionne pas le fichier garde l'ID 0 malgré qu'un fichier l'ai déjà.

Franc j'ai mit au bon format mais je ne comprend pas trop l'histoire de boucle, as-tu un exemple ?

Merci d'avance !

**Franc** · 19/07/2023, 17h01

Ce n'est pas moi qui t'ai parlé de boucle. J'ai une autre suggestion que tu peux tester, dans ton code, remplace ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
'TEST SI LE FICHIER EXISTE'
Fichier_existe = Dir(FichierAtester)
 
While Fichier_existe <> ""
    ID = ID + 1
    FichierAtester = NomDossier & ID & " " & "Demande d'achat_" & NomFournisseur & "_" & Emetteur & "_" & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ".xlsm"
    NomFichier = ID & " " & "Demande d'achat_" & NomFournisseur & "_" & Emetteur & "_" & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ".xlsm"
    Fichier_existe = Dir(FichierAtester)
Wend

par ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
' Vérification si un fichier avec le même nom existe déjà dans le répertoire '
Fichier_existe = Dir(NomDossier & "*" & "Demande d'achat_" & NomFournisseur & "_" & Emetteur & "_" & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ".xlsm")
 
' Boucle pour parcourir les fichiers existants dans le répertoire '
While Fichier_existe <> ""
 
    ' Variables pour déterminer la position de l'ID dans le nom du fichier existant '
    Dim StartPosition As Integer
    Dim EndPosition As Integer
 
    ' Ignore le chemin d'accès et le séparateur de chemin dans le nom du fichier existant '
    StartPosition = Len(NomDossier) + 1
 
    ' Recherche la première occurrence de l'espace après le chemin d'accès et avant l'ID dans le nom du fichier existant '
    EndPosition = InStr(StartPosition, Fichier_existe, " ")
 
    ' Variable pour stocker l'ID extrait du nom du fichier existant '
    Dim ExistingID As Integer
 
    ' Extraction de l'ID du nom du fichier existant en utilisant les positions StartPosition et EndPosition '
    ExistingID = Val(Mid(Fichier_existe, StartPosition, EndPosition - StartPosition))
 
    ' Vérifie si l'ID existant est supérieur ou égal à l'ID actuellement en cours de génération '
    If ExistingID >= ID Then
 
        ' Si l'ID existant est supérieur ou égal, on incrémente l'ID actuel en conséquence '
        ID = ExistingID + 1
 
    End If
 
    ' Recherche le prochain fichier dans le répertoire pour continuer la boucle '
    Fichier_existe = Dir
 
Wend

**Nausiboy** · 19/07/2023, 17h48

Oui désolé je me suis trompé.
Alors j'ai testé et cela ne marche pas il crée le fichier avec l'ID 0 car il a un fournisseur ou un émetteur différent.
J'ai aussi testé avec le même fournisseur et emetteur et cela crée une erreur sur la ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    ExistingID = Val(Mid(Fichier_existe, StartPosition, EndPosition - StartPosition))

Nom : Capture.PNG
Affichages : 86
Taille : 5,8 Ko

**fraflt69** · 19/07/2023, 18h29

Attention, la commande DIR ne garantit jamais que le dernier fichier traité sera le dernier fichier écrit (de date de création comme de modification la plus récente).
je ne vois pas alors comment sans faire un test de comparaison de supériorité sur la partie ID, on pourra sélectionner le fichier qui donnera l'ID le plus haut pour l'incrémenter.

Pour que la partie date du nom du fichier permette de différencier le fichier le plus récent dans l'ordre de création, il faudrait rajouter l'heure, cela constituerait une deuxième facon de sélectionner ou de confirmer le dernier fichier créé.

**Franc** · 19/07/2023, 19h20

Je pense qu'un classeur exemple pourrait aider.

**Nausiboy** · 19/07/2023, 19h22

Merci pour vos réponse
Tu veux que je partage mon classeur c'est cela ? !

**fraflt69** · 19/07/2023, 20h19

Bonsoir
Erreur sur la ligne

ExistingID = Val(Mid(Fichier_existe, StartPosition, EndPosition - StartPosition))

Pas étonnant

if StartPosition>=1 and EndPosition>StartPosition and IsNumeric(Mid(Fichier_existe, StartPosition, EndPosition - StartPosition)) Then
ExistingID= Val(Mid(Fichier_existe, StartPosition, EndPosition - StartPosition))
Else
Msgbox "Extraction ID Impossible"
End if

**Nausiboy** · 20/07/2023, 08h39

Bonjour fraflt69,

Je n'ai pas totalement compris le sens de ton message ?
Que faut-il faire avec ton extrait de code ?

Merci d'avance

**Fab_de_chez_PERFORM** · 20/07/2023, 12h48

Bonjour
dans les cas comme le votre, j'utilise une cellule nommée qui contient l'info (ex Num_ID)
J'utilise cela dans le nom donné lors de l'enregistrement et je l'incrémente en fin de sub pour le coup d'après

J'ai fait un exemple rapidos dans le fichier joint

**Nausiboy** · 20/07/2023, 14h57

Salut Fab.
Merci pour ta réponse.
j'ai trouver une solution qui fonctionne pour mon cas je vous la joint si dessous.
En faite comme mon dossier ne contient que les enregistrement de demande d'achat je compte le nombre de fichier pour mettre a jour l'ID.
Merci tout le monde pour votre temps et votre implication !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub test()
Dim dossier As String
Dim ID As Integer
Dim fichier As String
 
dossier = "S:\SOL-F\Projets\Nouvelle demande d'achat\Maintenance\"
ID = 0
fichier = Dir(dossier)
Do While fichier <> ""
   If fichier Like "*Demande d'achat_*.xlsm" Then
   ID = ID + 1
   fichier = Dir
   End If
Loop
 MsgBox ID
 
End Sub

Bonne journée !!

Enregistrement d'un fichier en VBA

Macros et VBA Excel

Discussions similaires

Partager

Partager