Boucle et création dossier

Bonjour à tous,

Alors voilà jusqu'ici j'ai réussi a me débrouiller pour créer des macros etc...

Mais je suis débutant et je bloque sur un point et malgré mes nombreuses recherche je ne trouve pas de solution.

Je vous explique je suis en train de créer un tableau excel de suivi d'affaire, dans l'idée je souhaite que lorsque la colonne date de prise en compte et complétée, un dossier soit créer avec des sous dossier etc... jusque là pour moi tout va bien.

Cependant je ne trouve pas de solution si le dossier existe déjà.

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Dim Moi As Worksheet
Dim Numero_Nom As String
Dim dossier As String
Dim Ss_dossier As String
Dim Ss_dossier2 As String
Dim Jour As Range
Dim Ligne As Range
Dim i As Integer
Dim DQER As String
Dim DD As String

Set Moi = Worksheets(1)
Set Wordapp = CreateObject("word.application")

Set Jour = Range("M1:M" & Range("B65536").End(xlUp).Row)
DQER = "\\SERVEUR\Users\Aurélie\Documents\MES DONNEES\COMMUN\0ZZ - DOSSIER REFERENT A COPIER\DQE_OK.xlsm"
DD = "\\SERVEUR\Users\Aurélie\Documents\MES DONNEES\COMMUN\0ZZ - DOSSIER REFERENT A COPIER\References_cedric.docx"

For i = 1 To 100

If Cells(i, 13) = Date Then

Numero_Nom = Moi.Cells(i, 1) & "_" & "_" & Moi.Cells(i, 2) & "_" & Moi.Cells(i, 10)
dossier = "\\SERVEUR\Users\Aurélie\Documents\MES DONNEES\COMMUN\" & Numero_Nom & "\"
Ss_dossier = dossier & "A_valider" & "\"
Ss_dossier2 = dossier & "Photos" & "\"

On Error Resume Next

MkDir (dossier)
MkDir (Ss_dossier)
MkDir (Ss_dossier2)

Workbooks.Open (DQER)

ActiveWorkbook.Worksheets("DQE").Cells(2, 2) = Moi.Cells(i, 2)
ActiveWorkbook.Worksheets("DQE").Cells(3, 2) = Moi.Cells(i, 7)
ActiveWorkbook.Worksheets("DQE").Cells(4, 2) = Moi.Cells(i, 9)
ActiveWorkbook.Worksheets("DQE").Cells(5, 2) = Moi.Cells(i, 10)
ActiveWorkbook.Worksheets("DQE").Cells(6, 2) = Moi.Cells(i, 11)

ActiveWorkbook.SaveAs Filename:=dossier & "DQE" & "_" & Moi.Cells(i, 10), FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", writerespassword:="", ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close

Workbooks.Open ("\\SERVEUR\Users\Aurélie\Documents\MES DONNEES\COMMUN\FICHES RENSEIGNEMENTS\Fiches Renseignements clients.xlsx")

ActiveWorkbook.Worksheets("Feuil1").Cells(1, 13) = Moi.Cells(i, 10)
ActiveWorkbook.Worksheets("Feuil1").Cells(2, 13) = Moi.Cells(i, 3)
ActiveWorkbook.Worksheets("Feuil1").Cells(2, 17) = Moi.Cells(i, 17)
ActiveWorkbook.Worksheets("Feuil1").Cells(4, 13) = Moi.Cells(i, 11)
ActiveWorkbook.Worksheets("Feuil1").Cells(8, 13) = Moi.Cells(i, 12)
ActiveWorkbook.Worksheets("Feuil1").Cells(15, 17) = Moi.Cells(i, 8)
ActiveWorkbook.Worksheets("Feuil1").Cells(16, 17) = Moi.Cells(i, 9)

ActiveWorkbook.PrintOut

ActiveWorkbook.Close savechanges:=False

Wordapp.documents.Open (DD)

Wordapp.Visible = True

Wordapp.ActiveDocument.SaveAs Filename:=dossier & "DD" & "-" & Moi.Cells(i, 10) & ".doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False

Wordapp.ActiveDocument.Close savechanges:=False

On Error Resume Next

End If

Next i

End Sub

Edit modo : code mis entre balises

Bonjour,

Pour poster du code, vous pouvez utiliser les balises </> du ruban d'icônes.

Vous voulez tester l'existence du dossier, c'est ça ? Pouvez-vous essayer ceci :

if dir(dossier, vbdirectory) = "" then
    mkdir dossier
end if

NB : Il faut que le dossier ne termine pas par un antislash !!!

Cdlt,

Sinon essayez avec cette fonction :

sub Main()
'code
if not FolderExists(dossier) then
    mkdir dossier
end if
end sub

function FolderExists(sFolderPath as string) as boolean
s = iif(sFolderPath like "*\", left(sFolderPath, len(sFolderPath) - 1), sFolderPath)
if dir(s, vbdirectory) <> "" then FolderExists = true
end function

Cdlt,

Bonjour,

Oui veuillez m'excuser je n'ai pas l'habitude de poster sur le forum.

Peut-être que le plus simple serait que je poste le fichier excel, il faut que je vérifie d'abord qu'il n'y ait pas d'information sur l'entreprise pour laquelle je travaille.

Ma macro c'est beaucoup de bidouillage

Aucun problème, je comprends.

Alors, je suis désolé mais je n'ouvre pas les fichiers excel postés sur le forum. Mais le principe est là. Une fonction teste l'existence d'un dossier dont on a renseigné le chemin en argument. Lorsque le dossier n'existe pas, il est créé.

Edit modo : doublon avec https://forum.excel-pratique.com/s/goto/1101008

Bonjour Leponge et

Une petite présentation ICI serait la bienvenue

Si vous ne l'avez pas encore fait, je vous invite à lire :
- La charte du forum
- Quelques fonctionnalites du forum à connaître

Regardez aussi les petites icônes mises à votre disposition dans la barre de menu qui :
- vous permettent de poster un code (</>)
- de citer une phrase (" ")
- ou de clôturer un fil lorsque vous avez terminé (V)

Concernant votre demande, j'aurais une 1ère question, pourquoi mettre le code dans "Workbook_BeforeClose"
puisque vous nous dites " je souhaite que lorsque la colonne date de prise en compte et complétée, un dossier soit créer avec des sous dossier etc"

Merci pour votre participation

Cordialement

Re,

concernant votre demande, normalement il suffit de faire comme ceci

    On Error Resume Next
    If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier
    If Dir(Ss_Dossier, vbDirectory) = "" Then MkDir Ss_Dossier
    If Dir(Ss_Dossier2, vbDirectory) = "" Then MkDir Ss_Dossier2
    On Error GoTo 0

Sinon par rapport à ma question, j'ai modifié votre classeur, le voici

A+