XL 2013 Création de dossier via VBA

[STARRAG]

Bonjour à tous,


J'ai besoin de votre aide concernant ma macro.
J'utilise une macro pour copier un onglet d'un fichier excel et me le coller dans un nouveau fichier excel.
Ensuite, elle me demande où je dois enregistrer le document.
Jusqu'à la, elle fonctionne très bien.

Par contre, je voudrais savoir s'il est possible de créée directement un dossier et qu'il enregistre le fichier excel dedans?
Le nom du fichier qu'il doit générer est : N° + le numéro de la case E3
Et je voudrais aussi qu'il vérifie si un fichier porte déjà le même nom.

J'espère être assez clair.
Merci d'avance de votre aide.

Sub copiecolle()

Dim NomFichier As String
Dim ChemFichier As String

Sheets("Note vierge").Select
Sheets("Note vierge").Copy
Cells.Select
Range("A4").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False

NomFichier = "Note de Demande d'amélioration n° " & Range("E3")
ChemFichier = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path & "\" & NomFichier, Filefilter:="Fichier Excel(*.xls), *.xls")

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=NomFichier
Application.DisplayAlerts = True
MsgBox "Le fichier a été sauvegardé avec succès"

End Sub

 

[patricktoulon]

bonjour
ok c'est pas trop mal mais on peut simplifier et surtout suprimer ces select et activate
si un fichier du même nom existe on fait quoi
le dialog saveas t est il vraiment nécessaire?

Sub copiecolle()

    Dim NomFichier$, Chemin$, rep As VbMsgBoxResult

    Sheets("Note vierge").Copy    'on crée le classeur
    With ActiveWorkbook.ActiveSheet
        .UsedRange.Value = .UsedRange.Value    ' on durci les valeurs(supprime toute formule)
        NomFichier = "Note de Demande d'amélioration n° " & .Range("E3") & ".xlsx"
    End With
    Chemin = ThisWorkbook.Path & "\"
    If Dir(Chemin & NomFichier) <> "" Then
        rep = MsgBox("un fichier du meme nom existe" & vbCrLf & " voulez vous l'écraser poil au nez :) ", vbYesNo)
        If rep = vbYes Then
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=Chemin & NomFichier
            Application.DisplayAlerts = True
            MsgBox "Le fichier a été sauvegardé avec succès"
        Else
            'on fait quoi si tu veux pas écraser!!!!!!!!!!!!

        End If

    End Sub
    'ChemFichier = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path & "\" & NomFichier, Filefilter:="Fichier Excel(*.xls), *.xls")

 

[STARRAG]

Salut PatrickToulon,

Je suis un débutant en VBA, du coup je m'aide de différent forum pour réaliser mon code.
Du coup, c'est normal si le code est un peu anarchique.
Je l'ai modifié pour qu'il vérifie si un dossier à le même nom que celui que je veux créer.
Par contre, il ne veut pas sauvegarder tout seul le fichier.

Sub CopyAndSave()
 
Dim FolderPath$, Nom$

Sheets("Note vierge").Select
Sheets("Note vierge").Copy
Cells.Select
Range("A4").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False

Nom = "Note de demande d'amélioration n°" & Range("E3")

With ActiveSheet.Range("A1:E58")
       .Value = .Value
End With

NomDossier = "N°" & Range("E3")
FolderPath = "T:\ATELIER\AMELIORATIONS CONTINUES\Pièces jointes" & "\" & NomDossier & "\"

If Dir(FolderPath, vbDirectory) = "" Then
        MkDir FolderPath
        ChDir FolderPath
        Application.Dialogs(xlDialogSaveAs).Show Nom
        Else
        MsgBox "ATTENTION : Dossier déjà existant."
        Application.Dialogs(xlDialogSaveAs).Show Nom
End If
End Sub