Option Explicit
Private Rep As String
Private Wbk As String
Private WordApp As Word.Application
Private WordDoc As Word.Document
Private u As Integer
Private RefRow As Long
Private PasteEntete As Boolean
Private Fso As Scripting.FileSystemObject
Private SourceFolder As Scripting.Folder
Private SubFolder As Scripting.Folder
Private FileItem As Scripting.File
Sub Import()
Dim Response
Dim Repertoire As FileDialog
Dim Dossier As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Wbk = ThisWorkbook.Name
Dossier = ThisWorkbook.Path & "\DPR"
'Traitement des fichiers
ListeSousDossier Dossier
MsgBox ("Importation terminée!")
End Sub
Sub ListeSousDossier(Repertoire As String)
'Appel récursif pour créer les onglets et lister les fichier dans les sous-répertoires
For i = Val(Cells(10, 5)) To Year(Now())
Rep = i
Sheets.Add.Name = Rep
Sheets(Rep).Tab.ColorIndex = 4
Sheets(Rep).Move After:=Worksheets(Worksheets.Count)
PasteEntete = False
ListeFichiers (Repertoire & "\" & Rep)
Next i
End Sub
Sub ListeFichiers(Repertoire As String)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
'Boucle sur tous les fichiers du répertoire
For Each FileItem In SourceFolder.Files
RefRow = Val(Left(SubFolder.Name, InStr(1, SubFolder.Name, "-") - 1) - 1) * 18
If PasteEntete = False Then
Sheets("Commande").Select
Range("M3:M15").Select
Selection.Copy
Sheets(Rep).Select
Range("A5").Offset(RefRow, 0).Select
ActiveSheet.Paste
Columns("A:A").AutoFit
Range("A5").Offset(RefRow - 3, 0).Value = Mid(SubFolder.Name, InStr(1, SubFolder.Name, "-") + 1)
PasteEntete = True
End If
If FileItem.Type = "Microsoft Word Document" Then
'Extrait le jour du nom de fichier (date type xx-xx-xx ou xx-janv-xx)
Range("A5").Offset(RefRow - 3, Left(FindDate(FileItem.Name), 2)).Value = Left(FindDate(FileItem.Name), 2)
'Extrait la deuxième colonne du tableau
Extract FileItem.Path
'Ajoute un hyperlien vers le fichier
Sheets(Rep).Select
ActiveSheet.Hyperlinks.Add Anchor:=Range("A5").Offset(RefRow - 3, Left(FindDate(FileItem.Name), 2)), _
Address:=FileItem.ParentFolder & "\" & FileItem.Name
End If
Next FileItem
For Each SubFolder In SourceFolder.SubFolders
PasteEntete = False
ListeFichiers SubFolder.Path
Next SubFolder
Set SubFolder = Nothing
Set SourceFolder = Nothing
Set Fso = Nothing
End Sub
Function FindDate(ByVal txt As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "\d{2}\-.{2,9}\-\d{2}"
If .test(txt) Then FindDate = .Execute(txt)(0)
End With
End Function
Sub Extract(fichier As String)
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(fichier, ReadOnly:=True)
u = WordDoc.InlineShapes.Count
If WordDoc.InlineShapes(u).Type = wdInlineShapeEmbeddedOLEObject Then
If Left(WordDoc.InlineShapes(u).OLEFormat.progID, 11) = "Excel.Sheet" Then
WordDoc.InlineShapes(u).OLEFormat.DoVerb (wdOLEVerbOpen)
WordDoc.InlineShapes(u).OLEFormat.Object.Parent.ActiveWindow.VisibleRange.Offset(0, 1).Copy
Windows(Wbk).Activate
Sheets(Rep).Select
Range("A5").Offset(RefRow - 2, Left(FindDate(FileItem.Name), 2)).Select
ActiveSheet.Paste
End If
Else
MsgBox ("Time Analysis non trouvé." & Chr(10) & fichier)
Range("A5").Offset(RefRow - 2, Left(FindDate(FileItem.Name), 2)).Value = "XX"
End If
WordDoc.Close SaveChanges:=False
WordApp.Quit
End Sub