XL 2016 Gestion de chemin de fichiers + VBA

[Ryoken]

Bonjour la communauté,

J'ai encore besoin de votre aide. Après maintes recherches, essai et compilation diverses, je sèche.

Voilà l'énoncé de mon problème:

J'ai un fichier Excel (modèle avec macro) de base qui se nome calculateur.xltm. Une fois ouvert, l'utilisateur rentre des données puis une fois terminé, clique sur un bouton "enregistrer". C'est sur ce bouton que je flanche.

D'une part, il doit renommer le fichier vierge, selon des variables remplies par l'utilisateur (ca fonctionne). Il doit aussi créer un numéro de document (précédent document +1) stocké dans un autre fichier externe nommé "archives.xlsx". Du coup il doit ouvrir "archives", pointer sur une cellule fixe, qui donne déjà la dernière valeur de la colonne non vide, et modifier dans "calculateur" le n° modifié. Ensuite créer un nouveau dossier + nouveau fichier Excel + nouveau fichier PDF. IL doit également ajouter les nouvelles données du fichier "calculateur" dans le fichier "archives".

Pour corser un peu le tout, si le dossier existe déjà, il doit vérifier si existant (ca fonctionne à peu prêt) et le remplacer tout en gardant le n° actuel de document.


Voici mon code, mais je suis embêté avec la gestion des noms de fichiers.

Pour résumer:

Fichier de base nommé "calculateur", qui doit ensuite se renommer en "mon fichier selon variables", créer un nouveau dossier+nouveaux fichiers renommés, puis ajouter des données dans "archives" pour mettre à jour.

Le gros problème et que au début il a un nom défini fixe. Puis il change de nom, qui varie d'un document à l'autre selon les variables de chemin. Et c'est la la difficulté, car je n'arrive pas à lui définir un chemin variable du nouveau nom de fichier.

Voici mon code de base (qui fonctionne sans l'incrémentation du n° de document):

Sub save()
Dim Chemin As String, NomFichier As String
Dim extension As String

    Dim fdObj As Object
    Application.ScreenUpdating = False
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists(Sheets("lien").Range("T1")) Then
        MsgBox "Dossier trouvé / Datei gefunden", vbInformation, "Kutools for Excel"
    Else
        fdObj.CreateFolder (Sheets("lien").Range("T1"))
        MsgBox "Dossier créé / Ordner erstellt", vbInformation, "Kutools for Excel"
    End If
    Application.ScreenUpdating = True


  Application.ScreenUpdating = False
  Chemin = Sheets("lien").Range("T1") & "\"

  'Chemin = ThisWorkbook.Path & "\" & Range("C1") & "\"    ' Mon chemin (A supprimer)
  extension = ".xlsm"
  On Error Resume Next
  MkDir Chemin
  On Error GoTo 0
  NomFichier = Sheets("lien").Range("T6")

  With ActiveWorkbook
    .SaveAs Filename:=Chemin & NomFichier, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

  End With


Chemin = Sheets("lien").Range("T1") & "\"
Sheets("Impression").Visible = True
Sheets("impression").Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Sheets("lien").Range("T3") & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Sheets("Impression").Visible = False
Sheets("calculateur").Select

MsgBox "Les fichiers ont a bien été créés / Die Dateien wurden erstellt"

End Sub

et voici mon code modifié acutel:

Sub save()


Dim Chemin As String, NomFichier As String
Dim extension As String

Application.ScreenUpdating = False


  'Chemin = ThisWorkbook.Path & "\" & Range("C1") & "\"    ' Mon chemin (A supprimer)
  extension = ".xlsm"
  On Error Resume Next
  MkDir Chemin
  On Error GoTo 0
   NomFichier = Worksheets("lien").Range("T6")
    Dim fdObj As Object
    Application.ScreenUpdating = False
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists(Worksheets("lien").Range("T1")) Then
        MsgBox "Dossier trouvé / Datei gefunden", vbInformation, "Kutools for Excel"
    Else
    Fichier = Worksheets("Lien").Range("t4").Value
   Worksheets("Lien").Range("E1").Value = 1
    Workbooks.Open Filename:="C:\Users\Archives.xlsx"
   
    Workbooks("fichier").Activate
    Workbooks(Fichier).Worksheets("Impression").Range("R1").Value = Workbooks("Archives.xlsx").Worksheets("data").Range("N1").Value + 1
    Workbooks("Archives.xlsx").Close True 'sans sauvegarde (True si sauvegarde)
   
fdObj.CreateFolder Workbooks("Calculateur.xltm").Worksheets("lien").Range("T1")
        MsgBox "Dossier créé / Ordner erstellt", vbInformation, "Kutools for Excel"
    End If
    Application.ScreenUpdating = True


  With ActiveWorkbook
    .SaveAs Filename:=Chemin & NomFichier, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

  End With


Chemin = Sheets("lien").Range("T1") & "\"
Sheets("Impression").Visible = True
Sheets("impression").Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Sheets("lien").Range("T3") & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Sheets("Impression").Visible = False

NomFichier = Sheets("lien").Range("T6")

Dim LastRow As Long

'Activer le classeur de destination
Workbooks.Open Filename:="C:\Users\Archives.xlsx"

LastRow = Workbooks("Archives.xlsx").Worksheets("data").Range("A" & Rows.Count).End(xlUp).Row



Workbooks(NomFichier).Worksheets("lien").Range("A31:L31").Copy 'date de la fiche 'Copier les cellules désirées
Workbooks("Archives.xlsx").Worksheets("data").Range("A" & LastRow + 1).PasteSpecial xlPasteValues 'Coller les cellules


'quitter le mode de copie (
Application.CutCopyMode = False

Workbooks("Archives.xlsx").Close True 'sans sauvegarde (True si sauvegarde)


Sheets("calculateur").Select



MsgBox "Les fichiers ont a bien été créés / Die Dateien wurden erstellt"

End Sub

Je vous remercie d'avance pour l'aide apportée