Sauvegarde de copie et création du filepath

Version imprimable

Bonjour,
Mon premier post ici, j'ai fais une recherche mais je n'ai pas trouvé speécifiquement ce que je cherche.

je me suis conçu un macro qui sert à archiver le workbook sur un serveur en employant comme nom les valeurs trouvées dans certaines cellules.

J'éprouve deux problèmes avec ce macro:
1- Si le chemin du fichier n'existe pas le macro retourne une erreur au lieu de le créer. Donc si dans ma feuille Installation la date est en 2010 et que je n'ai pas le dossier 2010 dans le dossier RAPPORT TSC sur mon serveur il ne créera pas ce dossier puis ensuite sauver le workbook avec le nom spécifié dans celui-ci. J'aimerais qu'il le fasse.

2- J'aimerais n'archiver qu'une copie et que le Workbook ne change pas de nom. Donc si j'ouvre le workbook "rapport clientx 2009" et que j'active mon macro j'aimerais qu'il sauvegarde la copie sur le serveur avec le nom approprié, qu'il crée le chemin si il n'existe pas et que lorsque terminé le workbook en cours se nomme encore "rapport clientx 2009" et que son chemin de sauvegarde sois le même qu'a l'ouverture.

Voici ou j'en suis:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub SaveWithVariableFromCell() Dim SaveYear As String Dim saveDate As Date Dim saveDateStr As String Dim SaveClient As String Dim SaveOrder As String saveDate = Range("Installation!E2") SaveYear = Year(saveDate) saveDateStr = Range("Installation!E2").Text savedateText = Range("Installation!E2").Text SaveClient = Range("Résumé!AA5") SaveOrder = Range("Résumé!E4") ActiveWorkbook.SaveAs Filename:="F:\operat\RAPPORT TSC\" & SaveYear & "\" & SaveOrder & "_" & SaveClient & "_" & saveDateStr & ".xls" End Sub
Pas obliger de répondre au deux problèmes non plus si vous n'avez une solution qu'à un seul d'entre eux je suis intéressé à la lire. Merci :)

Bonsoir,
Je ne sais pas si ça peut t'aider mais ci-dessous un code perso qui teste l'existence des dossiers, si ça te va, tu pourras adapter

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
Sub ENREGISTRER()
Dim nomdossier As String, nomcle As String, stmessage As String, racine As String, _
rep_annee As String, dateref As String, verif As String, rep_mois As String, rep_jour As String
'----------------------------------------------------------------------------------------------
If ActiveSheet.Name = "devis" Then
nomdossier = "archives_devis"
Else
nomdossier = "archives_factures"
End If
racine = Workbooks(ActiveWorkbook.Name).Path
 
Dir Workbooks(ActiveWorkbook.Name).Path
ChDir racine 'se place sur le repertoire du programme
 
If (verif = Dir(racine & "\" & nomdossier & "\", vbDirectory)) = vbEmpty Then 'On teste l'existence du répertoire nomdossier
    repert = racine & "\" & nomdossier
    Else
    MkDir racine & "\" & nomdossier 'on le crée s'il n'existe pas
    repert = racine & "\" & nomdossier
End If
ChDir repert
trouver_nb_fact 'module pour compter mes fichiers en archive
    'variable du dossier "annee"
    rep_annee = VBA.Format(Now(), "yyyy") 'classement dans le rep "année"
If (verif = Dir(repert & "\" & rep_annee, vbDirectory)) = vbEmpty Then 'On teste l'existence du répertoire "année"
    repert = repert & "\" & rep_annee
Else 'on le crée s'il n'existe pas
     MkDir rep_annee
    repert = repert & "\" & rep_annee
End If
ChDir repert
    'variable du dossier "mois"
    rep_mois = VBA.Format(Now(), "mm") 'classement dans le rep "mois"
If (verif = Dir(repert & "\" & rep_mois, vbDirectory)) = vbEmpty Then 'On teste l'existence du répertoire...
    repert = repert & "\" & rep_mois
Else 'on le crée s'il n'existe pas
    MkDir repert & "\" & rep_mois
    repert = repert & "\" & rep_mois
End If
    'variable du dossier "jour"
    rep_jour = VBA.Format(Now(), "yyyy mm dd") 'classement dans le rep "jour"
    'vérifie si le dossier "jour" existe, sinon le crée
If (verif = Dir(repert & "\" & rep_jour, vbDirectory)) = vbEmpty Then
    repert = repert & "\" & rep_jour
Else
    MkDir repert & "\" & rep_jour
    repert = repert & "\" & rep_jour
End If
'ensuite c'est ma tambouille
'vérifie si le nom et adresse du client a bien été précisé
nomfeuil = ActiveSheet.Name
If sheets(nomfeuil).Range("e2") = "" Then
    MsgBox "le nom du destinataire n'a pas été précisé"
    sheets(nomfeuil).Range("e2").Select
    fact_devis.Show
    Exit Sub
End If
dateref = Now
nomcle = sheets(nomfeuil).Range("e5")
sheets(nomfeuil).Range("f1") = VBA.Format(dateref, "yy mm dd") & " " & nomcle & VBA.Format(inombre + 1, "0000")
nomfichier = Replace(sheets(nomfeuil).Range("f1"), " ", "")
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       repert & "\" & nomfichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True
 
End Sub

J'ai les solutions à mes problèmes, afin de contribuer les voicis.

1- pour s'assurer que le dossier existe et le créer le cas échéant je vais me servir de la très exhaustive et géniale méthode de casefayere mais j'avais trouvé une façons rapide d'y arriver avec ce qui suit qui a pour effet de seulement créer un dossier de dernier niveau si il n'existe pas, je ne voulais pas risquer de créer un répertoire à la racine du serveur et toute une hiérarchie subséquente. Mais l'idée de glisser des messages d'erreur approprié et de vérifier ou l'erreur se trouve est très pro, je vais m'en servir.
Code:

1 2 On Error Resume Next MkDir "O:\Operations\RAPPORT TSC\" & SaveYear
2- pour sauvegarder une copie sur serveur sans modifier le fichier en cours, ni son emplacement, ni son nom il suffit de se servir de SaveCopyAs (DUH!). donc:

Code:

ActiveWorkbook.SaveCopyAs

Donc ça donne:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub SaveWithVariableFromCell() Dim SaveYear As String Dim saveDate As Date Dim saveDateStr As String Dim SaveClient As String Dim SaveOrder As String Dim curdate As String Dim curtime As String saveDate = Range("Installation!E2") SaveYear = Year(saveDate) saveDateStr = Range("Installation!E2").Text savedateText = Range("Installation!E2").Text SaveClient = Range("Résumé!AA5") SaveOrder = Range("Résumé!E4") curdate = Date curtime = Time On Error Resume Next MkDir "O:\Operations\RAPPORT TSC\" & SaveYear On Error Resume Next ActiveWorkbook.SaveCopyAs Filename:="O:\Operations\RAPPORT TSC\" & SaveYear & "\" & SaveOrder & "_" & SaveClient & "_" & saveDateStr & ".xls" Range("Résumé!AY2").Select ActiveCell.Formula = "archivé le " & curdate & " à " & curtime End Sub