Option Explicit
Private Declare PtrSafe Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Public t As Double, i&, nomdeb$, Rep$, chemin$, derl&
Private Sub CreationDossier(sNomRep As String)
SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub
Sub Creer_Dossier()
Dim WordApp As Word.Application, WordDoc As Word.Document
Dim xlApp As New Excel.Application, xlBook As Workbook, NomFichier As String
Dim rg, nFile, tmp, a, b
Sheets(1).Activate
derl = ActiveSheet.Range("A65536").End(xlUp).Row
nomdeb = "C:\Documents Privés\" 'Crée le dossier
'Ensuite les sous-dossiers et les fichiers
On Error Resume Next
For i = 2 To derl
Application.GoTo ActiveSheet.Range("A" & i)
Rep = ActiveCell.Value
CreationDossier nomdeb & Rep & "\"
chemin = nomdeb & Rep & "\" & ActiveSheet.Range("B1").Value & ".doc"
NomFichier = nomdeb & Rep & "\" & ActiveSheet.Range("B1").Value
With Worksheets("Feuil1")
rg = Rep
End With
nFile = NomFichier & ".txt"
Open nFile For Output As #1
For a = 1 To UBound(rg, 1)
tmp = " "
For b = 1 To UBound(rg, 2)
If tmp > "" Then
tmp = tmp & Chr(34) & rg(a, b) & Chr(34)
Else
tmp = rg(a, b)
End If
Next
Print #1, tmp
Next
Close #1
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs NomFichier & " - " & ActiveSheet.Range("A" & i).Value
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Add
With WordApp.Selection
.Text = ActiveSheet.Range("B2").Value & i
.ParagraphFormat.Alignment = wdAlignParagraphRight
.Font.Name = "Verdana"
.Font.Size = 9
.Font.Bold = True
End With
With WordDoc.Sections(1)
.Footers(wdHeaderFooterPrimary).Range.Text = chemin
.Footers(wdHeaderFooterPrimary).Range.Paragraphs.Alignment = wdAlignParagraphCenter
'.Footers(wdHeaderFooterPrimary).PageNumbers.Add
End With
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
WordDoc.SaveAs chemin
WordApp.ActiveDocument.Close
Set WordApp = Nothing
If Rep = "" Then Exit Sub
t = Timer + 1: Do Until Timer > t: DoEvents: Loop
Next
End Sub