Enregistrement d'un fichier en VBA

Version imprimable

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:

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

Salut, teste comme ceci:
Code:

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

19/07/2023, 14h51
fraflt69

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.
19/07/2023, 15h04
Nausiboy

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 !

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:

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:

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

19/07/2023, 16h48
Nausiboy

1 pièce(s) jointe(s)

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:

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

Pièce jointe 641579
19/07/2023, 17h29
fraflt69

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éé.
19/07/2023, 18h20
Franc

Je pense qu'un classeur exemple pourrait aider.
19/07/2023, 18h22
Nausiboy

Merci pour vos réponse
Tu veux que je partage mon classeur c'est cela ? !
19/07/2023, 19h19
fraflt69

Bonsoir
Erreur sur la ligne

Citation:

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

Pas étonnant

Citation:

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
20/07/2023, 07h39
Nausiboy

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
20/07/2023, 11h48
Fab_de_chez_PERFORM

1 pièce(s) jointe(s)

Alternative

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

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:

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