Creer un dossier avec code vba

Fermé
dimitri - 31 janv. 2012 à 16:43
borntobealive Messages postés 138 Date d'inscription jeudi 17 juillet 2014 Statut Membre Dernière intervention 25 février 2019 - 18 juil. 2014 à 10:04
Bonjour,

bonjour à tous,
J'ai fait le tour de plusieurs forums et je n'arrive tjs pas à aboutir.
J'ai regardé le sujet : [Excel VBA] Créer des dossiers sous VBA [Résolu] mais je n'aboutit pas au succés.
Je suis novice sous vba et j'aurai besoin d'aide pour :
A partir d'un onglet / copier onglet dans un nouveau répertoire avec pour le nom du dossier la valeur d'une cellule et pour le nom du fichier la valeur d'une autre cellule.
J'ai réussi à coder le copier coller + nouveau nom du fichier dans un répertoire.
Là ou je bloque c'est pour d'abord créer le dossier puis enregistrer le fichier dedans.
code déjà fait :
Range("A1:AK38").Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.Zoom = 115
ActiveWindow.Zoom = 130
ActiveWindow.Zoom = 145
ActiveWindow.Zoom = 160
ActiveWindow.DisplayGridlines = False
Chemin = "réseau"

ActiveWorkbook.SaveAs Chemin & [G4] & "-" & [G3] & "-documentation" & ".xls"
ActiveWindow.Close
Range("Aq11").Select
ActiveCell.FormulaR1C1 = "Fichier " & [G4] & " Enregistré"
Range("AP11:BC11").Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 50
Range("R4").Select
Selection.ClearContents
Range("D16:D29").Select
Selection.ClearContents

pour la création du dossier, j'ai repris cela : la macro tourne mais rien ne ce passe...
Private Sub CommandButton4_Click()
If Dir(ThisWorkbook.Path & [D13], vbDirectory) = "P:\Tcrsra\SRA_2\PDF-AFFAIRES-SRA2\Documentation fin d'affaire\" Then MkDir ThisWorkbook.Path & [D13]
ThisWorkbook.SaveCopyAs ThisWorkbook.Path & [D13] & Format(Date, "YYYYMMDD") & "_" & Format(Now, "HHMMSS") & ".xls"
End Sub

Comment combiner les deux ????
A voir également:

3 réponses

Réponse 1 / 3
lermite222 Messages postés 8724 Date d'inscription dimanche 8 avril 2007 Statut Contributeur Dernière intervention 22 janvier 2020 1 191
Modifié par lermite222 le 31/01/2012 à 19:47
Bonjour,
A partir d'un onglet / copier onglet dans un nouveau répertoire
Ce code fait ça... 
Sub CopierFeuilleDansAutreClasseur() 
Dim WkSource As Workbook 
Dim WkCopie As Workbook 
Dim Chemin As String 
    Set WkSource = ThisWorkbook 
    Set WkCopie = Workbooks.Add 
    WkSource.Sheets("Feuil1").Copy Before:=WkCopie.Sheets(1) 
    With WkSource 
        Chemin = .Path & "\" & .[G4] & "\" 
    If Dir(Chemin) = "" Then MkDir Chemin 
    Application.DisplayAlerts = False 
    WkCopie.SaveAs Chemin & "\" & "-" & .[G3] & _ 
    "-documentation.xls" 
    Application.DisplayAlerts = True 
    End With 
    WkCopie.Close 
    WkCopie = Nothing 
    WkSource = Nothing 
End Sub

Pour info :
Tester si un répertoire existe avec Dir.
Si Dir renvoi "" c'est que le répertoire n'existe pas faut l créer.
Note : Dir ne crée pas les sous-répertoires s'ils n'existent pas, il faut employer une cascade comme.. 
Sub CascadeRepertoires() 
Dim TB, S As String, i As Integer 
    Dim Chemin As String 
    'Créer un répertoire et sous-Répertoire 
    Chemin = "C:\Test1\Test2" 
    TB = Split(Chemin, "\") 
    If Dir(Chemin) = "" Then 
        S = TB(0) & "\" ' & TB(1) 
        For i = 1 To UBound(TB) 
            S = S & TB(i) & "\" 
            If Dir(S) = "" Then 
                MkDir S 
            End If 
        Next 
    End If 
End Sub

Je t'ai mis ça au cas ou G4 serait du genre Rep1\Rep2
Et évite tout ces Select qui proviennent de l'éditeur de macro.
Emploi directement les objets. 
    With Range("AP11:BC11")
        .Font.Bold = True
        .Font.ColorIndex = 50
        .Interior.ColorIndex = 36
    End With

Tu dis.
A+
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius)
NOTE : Je ne répond pas aux MP pour les questions techniques.
1
Réponse 2 / 3
pierrot69
17 juil. 2014 à 11:01
slt,

Desolé pour le deterage de post, ce code est exactement ce dont j'ai besoin sauf que quoi qu'il arrive la fonction dir me renvoi toujours "" même quand je cherche dir (D:\) ce qui est évidement impossible

quelqu'un saurait pourquoi ?
0
Réponse 3 / 3
borntobealive Messages postés 138 Date d'inscription jeudi 17 juillet 2014 Statut Membre Dernière intervention 25 février 2019 7
18 juil. 2014 à 10:04
attention si vous ne rajoutez pas vbdirectory dans les attributs de la fonction dir et que vous chercher des repertoires, elle vous renverra toujours ""

essayez plutôt : 

Sub CascadeRepertoires() 
Dim TB, S As String, i As Integer 
    Dim Chemin As String 
    'Créer un répertoire et sous-Répertoire 
    Chemin = "C:\Test1\Test2" 
    TB = Split(Chemin, "\") 
    If Dir(Chemin, vbDirectory) = "" Then 
        S = TB(0) & "\" ' & TB(1) 
        For i = 1 To UBound(TB) 
            S = S & TB(i) & "\" 
            If Dir(S, vbDirectory) = "" Then 
                MkDir S 
            End If 
        Next 
    End If 
End Sub
0