Macro Enregistrement dans répertoire à choisir

thenthelo

XLDnaute Junior
Bonjour,
Je souhaite créer un bouton pour enregistrer un fichier. Je veux pouvoir choisir le répertoire dans lequel enregistrer ce fichier mais je voudrais que pour ce choix Excel m’ouvre une fenêtre directement à un niveau donné du chemin. En effet le chemin d’accès est très long et je ne veux pas avoir à redescendre toute l’arborescence à chaque fois.
Mon chemin serait du genre : C:\Niveau1\niveau2\niveau3\niveau4 et il faudrait choisir quel niveau 5 on veut.
Ensuite le nom de mon fichier sera constitué de la cellule A1 de ma feuille puis l'extension .xlsx

Merci d'avance à ceux qui sauraient m'aider.
 

herve62

XLDnaute Barbatruc
Supporter XLD
Re : Macro Enregistrement dans répertoire à choisir

Bonsoir
Tu pourrais t'inspirer de ce que j'avais fait pour une appli >
choix pour l'ouverture
Donc dans ton cas c'est idem sauf que cela sera pour fermer et enregistrer
A toi d'en tirer la "Substantifique moelle"
Code:
' On va traiter si le chemin est CORRECT , sinon on pourra recommencer OU
' Quitter la Sub

direction = Dir(chemin & "\*.xls")
If direction = "" Then
mes = MsgBox(" Le chemin entré est erroné ou ne comporte pas" & Chr(13) & _
" de fichiers Excel", vbOKCancel)
If mes = vbCancel Then alors = MsgBox(" voulez vous quitter l'application ?", vbYesNo)
If alors = vbYes Then
Exit Sub
Else
GoTo deb
End If
End If
' Fin du traitement de Verification du Chemin
'-------------------------------------------------
Nbfic = 0
While direction > ""
Nbfic = Nbfic + 1
Nom_proj(Nbfic) = direction
' Va mettre le NOM de la personne (fichier) en Ligne 5
Sheets("Cumul").Cells(5, Nbfic + 1).Value = Left(direction, (Len(direction) - 4))
Sheets("FRAIS").Cells(5, Nbfic + 1).Value = Left(direction, (Len(direction) - 4))
direction = Dir()
Wend

Call tri_nom ' Pour toujours avoir les noms dans les memes colonnes

' Traitement si un fichier "Nom" est dejà ouvert

 For z = 1 To Nbfic
 Nom_fic = chemin & "\" & Nom_proj(z)
 If Fic_ouvert(Nom_fic) = True Then
 MsgBox "Le fichier " & Nom_proj(z) & " est ouvert" _
  & Chr(13) & "Il va Etre Fermé" & Chr(13) & "Si c'est le Programme , il doit être dans un autre Répertoire"
  Workbooks(Nom_proj(z)).Close savechanges:=False
 End If
 Next z
 ' A partir d'ici tout est correct les fichiers ouverts ont été fermé
 
For x = 1 To Nbfic

    Workbooks.Open(Filename:=chemin & "\" & Nom_proj(x)) _
        .RunAutoMacros Which:=xlAutoOpen
       
    Nom_p = Left(Nom_proj(x), (Len(Nom_proj(x)) - 4))
    
    With Worksheets("RecapGéné")
    der_lig = .Range("A65000").End(xlUp).Row
    Call nom
        For y = 6 To der_lig
        P1 = .Cells(y, 1).Value                             ' N° de Projet du classeur "Total"
        P2 = ThisWorkbook.Sheets("Cumul").Cells(y, 1).Value '  "    "    " du classeur "Nom.Prenom"
    ' Comme les projets sont tous dans le meme Ordre ( Ce fichier et ceux "Nom.prenom")
    ' On laisse sur la meme ligne , ex: P1 valeur en ligne 6 et P2 Aussi
        If P1 = P2 Then
        ' comme on trouve les 2 N° identiques , on prend le Tps du "Nom_Prenom"
        ' et on cumule dans le fichier "Total_Projet" ( valeur précedente + nouvelle valeur)
        ThisWorkbook.Sheets("Cumul").Cells(y, Col_Nom).Value = ThisWorkbook.Sheets("Cumul").Cells(y, Col_Nom).Value + .Cells(y, 3).Value
        ThisWorkbook.Sheets("FRAIS").Cells(y, Col_Nom).Value = ThisWorkbook.Sheets("FRAIS").Cells(y, Col_Nom).Value + .Cells(y, 4).Value
        End If
        Next y
End With
Workbooks(Nom_proj(x)).Close savechanges:=False

Next x
 

herve62

XLDnaute Barbatruc
Supporter XLD
Re : Macro Enregistrement dans répertoire à choisir

bonjour , salut Pierrot
mais mon niveau VBA ne me permet pas d'adapter cette macro
je pense que c'est kif kif avec ta proposition il faut qu'il ajoute encore du code puisque :
il faut des variables pour qu'il choisisse le Niveau 5
je mets le principal :
Code:
chemin = InputBox("Indiquer le chemin complet du Repertoire" _
& Chr(13) & Chr(13) & "Exemple C:\Serveur1\Data\Projets" & Chr(13) & _
"Les Majuscules ou Minuscules n'ont pas d'importance")
' puis le nom de son classeur
Nom_fic = Input box( ...idem
'et le SAVE
Total_fic= chemin & "\" & Nom_fic & ".xlsm"
Workbooks(Total_fic).Close savechanges:=true
Cela devrait être plus facile à adapter
 

Discussions similaires

Réponses
19
Affichages
2 K