VBA - Isoler une feuille et l'enregistrer

Le 07/10/2020 à 14:11

Bonjour j'aimerai de l'aide sur la constuction de mon code VBA ayant pour but :

- Copier la feuille FORMULAIRE dans un nouveau classeur

- Sauvegarder ce nouveau classeur en tant que "Facture n°" "G3" " en date du " "G5" sous un chemin précis (différent du classeur "mère")

- Fermer tous les classeurs

J'ai actuellement ceci

Sheets("FORMULAIRE").Select
Sheets("FORMULAIRE").Copy

ChDir "C:\Users\TOTO\Desktop\lb"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\TOTO\Desktop\lb\Facture N°" & ActiveSheet.Range("G3") & " en date du " & ActiveSheet.Range("G5") & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
Sheets("FORMULAIRE").Activate
MsgBox ("Document sauvegardé")

Mais cela ne fonctionne pas

Merci pour votre aide

Le 07/10/2020 à 14:36

Bonjour

Je changerais la fin de votre macro pour mettre ceci:

Sheets("FORMULAIRE").Select
Sheets("FORMULAIRE").Copy

ChDir "C:\Users\TOTO\Desktop\lb"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\TOTO\Desktop\lb\Facture N°" & ActiveSheet.Range("G3") & " en date du " & ActiveSheet.Range("G5") & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
MsgBox ("Document sauvegardé")
ActiveWorkbook.Close
Le 07/10/2020 à 14:54

Bonjour,

Merci mais j'ai toujours une erreur d'exécution 1001 "Nous n'avons pas pu accéder au fichier. Assurez vous que le dossier spécifié existe".

Mon chemin est bien, le bon je ne comprends pas pourquoi il ne veut pas l'enregistrer sous ce nom. Est ce que vous pouvez jeter un coup d'oeil ? Ou proposer une macro avec "dim chemin", je ne maitrise pas...

Merci beaucoup

Le 07/10/2020 à 15:23

Voici une macro qui fonctionne chez moi

Sub extraction_avoir()

    Sheets("feuil1").Select
    Sheets("feuil1").Copy
    ChDir _
        "\\chemin du dossier"
    ActiveWorkbook.SaveAs Filename:= _
        "\\\\chemin du dossier \ nom du fichier" & anneemoisjour & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

End Sub

Par contre il me demande confirmation d'enregistrement sans macro et je l'active via un bouton.

Si vous avez une copie du fichier pour travailler directement dessus se serait plus simple.

Le 07/10/2020 à 15:27

Bonjour,

J'aurais écrit comme ça :

Sub EnregistrerFacture()
Dim wbk As Workbook
Dim chemin As String
Dim nom As String
  chemin = "C:\Users\TOTO\Desktop\lb\"
  If Dir(chemin) = "" Then MsgBox "Le chemin de destination n'existe pas :" & vbCrLf & chemin: Exit Sub
  Set wbk = Workbooks.Add(xlWBATWorksheet)
  ThisWorkbook.Worksheets("FORMULAIRE").Copy before:=wbk.Worksheets(1)
  Application.DisplayAlerts = False
  wbk.Worksheets(2).Delete
  Application.DisplayAlerts = True
  With wbk.Worksheets("FORMULAIRE")
    nom = chemin & "Facture N°" & .Range("G3").Value & " en date du " & .Range("G5").Text & ".xls"
  End With
  If Dir(nom) = "" Then
    wbk.SaveAs Filename:=nom
  Else
    If MsgBox("Le fichier suivant existe déjà :" & vbCrLf & _
              nom & vbCrLf & vbCrLf & _
              "Voulez-vous l'écraser ?", vbCritical + vbYesNo + vbDefaultButton2) = vbYes Then
      Application.DisplayAlerts = False
      wbk.SaveAs Filename:=nom
      Application.DisplayAlerts = True
    End If
  End If
  wbk.Close False
End Sub

Note :

- Pour éviter tout problème lié au multitâche, je n'utilise les objets actif que quand je ne peux faire autrement.

- La date en G5 doit être dans un format acceptable dans le nom, sinon utiliser la fonction Format() pour l'y mettre.

Le 07/10/2020 à 15:54

Bonjour Patrice,

Merci pour votre travail, c'est du haut de gamme.

Cela fonctionne parfaitement quand j'écris une date en haute lettre mais au format jj/mm/aaaa, ça me renvoie une erreur. le format doit être appliqué dans une formule ou en VBA ?

Le 07/10/2020 à 16:11

Re,

Il est nettement préférable de le faire au niveau du VBA.

Pour ma part, pour faciliter le tri dans Windows, j'utiliserais :

nom = chemin & "Facture N°" & .Range("G3").Value & " en date du " & Format(.Range("G5").Value, "yyyy-mm-dd") & ".xls"

Attention avec .Value et pas .Text

Le 07/10/2020 à 16:44

Parfait tout fonctionne, je vous remercie

Le 07/10/2020 à 17:09

Dans le même ordre d'idée, il faut peut-être aussi formater G3 avec 3 ou 4 chiffres ("000" ou "0000")

Le 07/10/2020 à 17:28

Aucun soucis vis à vis de la macro, le rendu est parfait.

Mais je viens de déplacer mon dossier sur le serveur pro, et le chemin est inexistant. J'ai bien sûr mis à jour mon chemin comme ceci

cheDim nom As String

min = "S:\LOGISTIQUE\6-TRANSPORT\Suivi prep

If Dir(chemin) = "" Then MsgBox "Le chemin de destination n'existe pas :" & vbCrLf & chemin: Exit Sub
Set wbk = Workbooks.Add(xlWBATWorksheet)

Et on me renvoie directement à la msgbox "Le chemin n'existe pas"

J'ai d'autres macro qui fonctionne plus ou moins pareil sur le serveur et le chemin est détecté. D'où pourrait venir le problème ?

Merci

Le 07/10/2020 à 18:55

ton code est mal copié, utilises le bouton code </> pour mettre du code dans ton post.

Le 08/10/2020 à 09:01

Merci, je suis débutant sur le forum

Dim wbk As Workbook
Dim chemin As String
Dim nom As String
  chemin = "S:\LOGISTIQUE\6-TRANSPORT\XXXX\Suivi prep XXXX"
  If Dir(chemin) = "" Then MsgBox "Le chemin de destination n'existe pas :" & vbCrLf & chemin: Exit Sub
  Set wbk = Workbooks.Add(xlWBATWorksheet)
  ThisWorkbook.Worksheets("FORMULAIRE").Copy before:=wbk.Worksheets(1)
  Application.DisplayAlerts = False
  wbk.Worksheets(2).Delete
  Application.DisplayAlerts = True
  With wbk.Worksheets("FORMULAIRE")
    nom = chemin & "Facture N°" & .Range("G2").Value & " en date du " & Format(.Range("G3").Value, "yyyy-mm-dd") & ".xls"
  End With
  If Dir(nom) = "" Then
    wbk.SaveAs Filename:=nom
  Else
    If MsgBox("Le fichier suivant existe déjà :" & vbCrLf & _
              nom & vbCrLf & vbCrLf & _
              "Voulez-vous l'écraser ?", vbCritical + vbYesNo + vbDefaultButton2) = vbYes Then
      Application.DisplayAlerts = False
      wbk.SaveAs Filename:=nom
      Application.DisplayAlerts = True
    End If
  End If
  wbk.Close False

Tout fonctionnait bien en local, mais ne fonctionne pas sur le serveur, alors que le chemin a bien été remplacé

Le 08/10/2020 à 13:27

Bonjour,

Je vous propose de tester votre code en ajoutant ce code, éventuellement sur un autre module :

'AVANT TOUT : ajouter la référence Microsoft Scripting Runtime !!!

Function TesterChaqueRepertoire(Chemin$) As Boolean

Dim fso As FileSystemObject
Dim Rep$
Dim Doss

Set fso = New FileSystemObject 'nouvel object file system
Rep = Chemin 'Rep vaut chemin
Doss = Split(Rep, "\") 'Dossier est un tableau de tous les dossiers

If Not LecteurExiste(Rep) Then 'si le lecteur n'existe pas
    Message = Doss(0) & " est introuvable !!!"
    Rep = "" 'permettra de renvoyer faux (voir étiquette Fin)
    GoTo Fin 'sortie fonction
End If

i = UBound(Doss) 'on commence par le dernier sous-dossier
While i > 0 'tant que i >0
    If Not DossierExiste(Rep) Then 'si le chemin n'existe pas
        Message = Message & Rep & " n'existe pas !!!" & vbCrLf & vbCrLf 'stocke dans msg
        Rep = Replace(Join(Doss, "\"), "\" & Doss(i), "") 'chemin tronque le dernier sous-dossier
        Doss = Split(Rep, "\") 'tableau imputé du dernier sous-dossier
        i = i - 1 'décrémentation
    Else 'sinon
        Message = Message & Rep & " est bien un chemin existant !" 'msg ok
        GoTo Fin 'sortie
    End If
Wend

Fin:
MsgBox Message 'permet de lister chaque inexistence de chemin jusqu'à réussite
If Rep = Chemin Then TesterChaqueRepertoire = True 'ssi rep = chemin, renvoie vrai

End Function

Function DossierExiste(Chemin$) As Boolean 'teste si dossier existe pour le chemin spécifié

Dim fso As FileSystemObject
Set fso = New FileSystemObject
If fso.FolderExists(Chemin) Then DossierExiste = True

End Function

Function LecteurExiste(Chemin$) As Boolean 'teste si lecteur existe pour le chemin spécifié

Dim fso As FileSystemObject
Set fso = New FileSystemObject
If fso.GetDriveName(Chemin) = Split(Chemin, "\")(0) Then LecteurExiste = True

End Function

Il faudra bien aller dans Outils/Références et ajouter la librairie Microsoft Scripting Runtime.

Ensuite, il faut modifier votre code comme suit :

Dim wbk As Workbook
Dim chemin As String
Dim nom As String
  chemin = "S:\LOGISTIQUE\6-TRANSPORT\XXXX\Suivi prep XXXX"
  If not TesterChaqueRepertoire(chemin) Then Exit Sub
  Set wbk = Workbooks.Add(xlWBATWorksheet)
  ThisWorkbook.Worksheets("FORMULAIRE").Copy before:=wbk.Worksheets(1)
  Application.DisplayAlerts = False
  wbk.Worksheets(2).Delete
  Application.DisplayAlerts = True
  With wbk.Worksheets("FORMULAIRE")
    nom = chemin & "Facture N°" & .Range("G2").Value & " en date du " & Format(.Range("G3").Value, "yyyy-mm-dd") & ".xls"
  End With
  If Dir(nom) = "" Then
    wbk.SaveAs Filename:=nom
  Else
    If MsgBox("Le fichier suivant existe déjà :" & vbCrLf & _
              nom & vbCrLf & vbCrLf & _
              "Voulez-vous l'écraser ?", vbCritical + vbYesNo + vbDefaultButton2) = vbYes Then
      Application.DisplayAlerts = False
      wbk.SaveAs Filename:=nom
      Application.DisplayAlerts = True
    End If
  End If
  wbk.Close False

L'idéal serait tout de même de bien contrôler le chemin avant de le saisir en dur car ça doit certainement être une petite faute de frappe, un espace indésirable en général...

Cdlt,

Rechercher des sujets similaires à "vba isoler feuille enregistrer"