1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
| Sub test()
Dim FSO As Object, Dossier As Object
Dim oWSS As Object, oGenvag As Object
Dim CheminBureau As String, C As Range
Dim wdApp As Object, pptApp As Object
Dim wdDoc As Object, pptDoc As Object
Set wdApp = CreateObject("Word.Application")
Set pptApp = CreateObject("Powerpoint.Application")
Set oWSS = CreateObject("WScript.Shell")
CheminBureau = oWSS.SpecialFolders("Desktop")
Set oWSS = Nothing
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Dossier = FSO.GetFolder(CheminBureau & "\F")
If Not Dossier Is Nothing Then
MsgBox "Le dossier F existe"
Exit Sub
End If
MkDir CheminBureau & "\F"
ChDir CheminBureau & "\F"
For Each C In Range([A2], Cells(Rows.Count, 1).End(xlUp))
ChDir CheminBureau & "\F"
For i = 2 To 100
If Cells(C.Row, i).Value = "" Then Exit For
If Cells(C.Row, i + 1) <> "" And Cells(C.Row, i) <> Cells(C.Row - 1, i) Then
MkDir CurDir & "\" & Cells(C.Row, i)
ChDir CurDir & "\" & Cells(C.Row, i)
ElseIf Right(Cells(C.Row, i), 5) = ".xlsx" Then
Workbooks.Add
Var = Cells(C.Row, i).Value
ActiveWorkbook.SaveAs ThisWorkbook.ActiveSheet.Cells(C.Row, i).Value, xlOpenXMLWorkbook
ActiveWorkbook.Close
ElseIf Right(Cells(C.Row, i), 5) = ".docx" Then
Set wdDoc = wdApp.Documents.Add
wdDoc.SaveAs Cells(C.Row, i).Value, wdFormatDocumentDefault
wdDoc.Close
ElseIf Right(Cells(C.Row, i), 5) = ".pptx" Then
Set pptDoc = pptApp.Presentations.Add
pptDoc.SaveAs Cells(C.Row, i).Value
pptDoc.Close
pptApp.Quit
Else
ChDir CurDir & "\" & Cells(C.Row, i)
End If
Next i
Next C
On Error GoTo 0
End Sub |
Partager