Option Explicit
' Liste les fichiers d'un dossier et de ses sous dossiers
' dans une feuille de calcul avec certains renseignements
' Créé par BrunoM45 - infopassion@free.fr
Public FlgFirst As Boolean, FlgVoir As Boolean
Sub MaJ_Historique()
Dim DerLig As Long, Lig As Long
Dim LigF As Long, LigF2 As Long, VSearch As String
Dim ShtL As Worksheet, ShtP As Worksheet
Dim LigH As Long, ShtH As Worksheet
Dim RootFolder As String
Dim FlgAjt As Boolean, FlgMod As Boolean, FlgSup As Boolean, FlgDep As Boolean
Dim IcAjt As Long, IcMod As Long, IcSup As Long, IcDep As Long
' Initialisation des variables objet
Set ShtL = Sheets("Listing")
Set ShtP = Sheets("Previous")
Set ShtH = Sheets("Histo")
With Sheets("Accueil")
FlgAjt = (.Range("FicAjt") = "Oui")
IcAjt = .Range("FicAjt").Interior.ColorIndex
FlgMod = (.Range("FicMod") = "Oui")
IcMod = .Range("FicMod").Interior.ColorIndex
FlgSup = (.Range("FicSup") = "Oui")
IcSup = .Range("FicSup").Interior.ColorIndex
FlgDep = (.Range("FicDep") = "Oui")
IcDep = .Range("FicDep").Interior.ColorIndex
' Visualiser l'avancement
FlgVoir = (.Range("VisuAvt") = "Oui")
' Répertoire de référence
RootFolder = .Range("DossierRef").Value
End With
' Effacer l'ancien historique
With ShtP
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
If DerLig > 1 Then
.Range("A2:H" & DerLig).EntireRow.Delete
End If
End With
' Choix du dossier à scanner
If RootFolder = "" Then
RootFolder = ChoisirDossier("Choisissez un répertoire")
End If
' si aucun dossier alors on sort de la procédure
If RootFolder = "" Then Exit Sub
' Copie de l'historique vers archives Histo
' Et effacer la feuille Listing
With ShtL
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
If DerLig > 1 Then
.Range("A2:H" & DerLig).Copy Destination:=ShtP.Range("A2")
.Range("A2:H" & DerLig).EntireRow.Delete
End If
End With
' Lister tous les fichiers du dossier et sous-dossier
ListFilesInFolder "Listing", RootFolder, True
' Si c'est la première fois, pas d'historique à faire
If FlgFirst = True Then FlgFirst = False: GoTo FinProc
'
' EFFECTUER ENSUITE L'HISTORIQUE
' AJOUT et MODIFICATION
With ShtL
' Visualiser l'avancement ou non
If FlgVoir Then .Activate
' Récupérer la dernière ligne de la feuille Listing
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DerLig
' Visualiser l'avancement ou non
If FlgVoir Then .Range("A" & Lig).Select
' Mettre à jour l'affichage du staut
Application.DisplayStatusBar = True
Application.StatusBar = "Historique AJT/MODIF vérification ligne : " & Lig & " sur " & DerLig
'
VSearch = .Range("C" & Lig).Value
LigF = LigFind(VSearch, ShtP.Name, "C")
If LigF = 0 Then
' Le fichier n'a pas été trouvé
.Range("H" & Lig).Value = "Ajouté"
.Range("A" & Lig & ":H" & Lig).Interior.ColorIndex = IcAjt
If FlgAjt = True Then
' Prochaine ligne vide dans historique
LigH = ShtH.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
' Inscrire l'historique
.Range("A" & Lig & ":H" & Lig).Copy Destination:=ShtH.Range("A" & LigH)
ShtH.Range("I" & LigH).Value = Now()
End If
Else
' Le fichier à été trouvé, vérifier la date
If .Range("E" & Lig) <> ShtP.Range("E" & LigF) Then
.Range("H" & Lig).Value = "Modifié"
.Range("A" & Lig & ":H" & Lig).Interior.ColorIndex = IcMod
If FlgMod = True Then
' Prochaine ligne vide dans historique
LigH = ShtH.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
' Inscrire l'historique
.Range("A" & Lig & ":H" & Lig).Copy Destination:=ShtH.Range("A" & LigH)
ShtH.Range("I" & LigH).Value = Now()
End If
Else
.Range("H" & Lig).Value = "RàS"
End If
End If
Next Lig
End With
' SUPPRESSION
With ShtP
' Visualiser l'avancement ou non
If FlgVoir Then .Activate
' Récupérer la dernière ligne de la feuille Listing
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DerLig
' Visualiser l'avancement ou non
If FlgVoir Then .Range("A" & Lig).Select
' Mettre à jour l'affichage
Application.DisplayStatusBar = True
Application.StatusBar = "Historique DEPLT/SUPPR vérification ligne : " & Lig & " sur " & DerLig
'
VSearch = .Range("C" & Lig).Value
LigF = LigFind(VSearch, ShtL.Name, "C")
If LigF = 0 Then
' Recherche si fichier déplacé
VSearch = .Range("B" & Lig).Value
LigF2 = LigFind(VSearch, ShtL.Name, "B")
If LigF2 <> 0 Then
' Le fichier a été trouvé mais dans un autre répertoire
.Range("H" & Lig).Value = "Déplacé"
.Range("A" & Lig & ":H" & Lig).Interior.ColorIndex = IcDep
If FlgDep = True Then
' Prochaine ligne vide dans historique
LigH = ShtH.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
.Range("A" & Lig & ":H" & Lig).Copy Destination:=ShtH.Range("A" & LigH)
ShtH.Range("I" & LigH).Value = Now()
End If
Else
' Le fichier n'a pas été trouvé
.Range("G" & Lig).Value = "Supprimé"
.Range("A" & Lig & ":H" & Lig).Interior.ColorIndex = IcSup
If FlgSup = True Then
' Prochaine ligne vide dans historique
LigH = ShtH.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
.Range("A" & Lig & ":H" & Lig).Copy Destination:=ShtH.Range("A" & LigH)
ShtH.Range("I" & LigH).Value = Now()
End If
End If
End If
Next Lig
End With
'
FinProc:
' Mettre à jour les date de MàJ
With Sheets("Accueil")
.Range("PreviousMaJ").Value = .Range("DerniereMaJ").Value
.Range("DerniereMaJ").Value = Now()
End With
' Effacer l'ancien TCD
With Sheets("TCD")
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:B" & DerLig).ClearContents
.Range("A1:B" & DerLig).ClearFormats
End With
' Dernière ligne de la feuille Listing
DerLig = ShtL.Range("A" & Rows.Count).End(xlUp).Row
' Lancer la création du TCD
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Listing!R1C1:R" & DerLig & "C7").CreatePivotTable TableDestination:= _
"'[" & ThisWorkbook.Name & "]TCD'!R1C1", TableName:= _
"TCD1", DefaultVersion:=xlPivotTableVersion10
With Sheets("TCD")
.PivotTables("TCD1").AddFields RowFields:= _
"Chemin d'accès"
.PivotTables("TCD1").PivotFields("Taille"). _
Orientation = xlDataField
' Formatage des nombre
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
.Range("B3:B" & DerLig).NumberFormat = "# ##0"" Ko"""
.Range("B:B").ColumnWidth = 13
.Activate
End With
MsgBox "Historique effectué, TCD créé, c'est terminé ;-)", vbInformation, "C'EST FINI ..."
' Effacer les variables objet
Set ShtL = Nothing
Set ShtP = Nothing
Set ShtH = Nothing
End Sub
Sub CompareFolder()
Dim Col As Integer, DerLig As Long, Lig As Long, RootFolder1 As String, RootFolder2 As String
Dim IcRec As Long, TpR() As String, Msg1 As String, Msg2 As String
' Définir le tableau des dates plus récentes
TpR = Split("Création,Modification,Accès", ",")
' Couleur à utiliser pour donnée plus récente
IcRec = Sheets("Accueil").Range("DonPR").Interior.ColorIndex
' Effacer l'ancien comparatif
With Sheets("Comparatif")
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
If DerLig > 1 Then
.Range("A2:H" & DerLig).EntireRow.Delete
End If
End With
' 1er dossier à analyser
RootFolder1 = Sheets("Accueil").Range("RepComp1").Value
' Choix du dossier à scanner
If RootFolder1 = "" Then RootFolder1 = ChoisirDossier("Choisissez le répertoire n° 1")
If RootFolder1 <> "" Then
Sheets("Accueil").Range("RepComp1").Value = RootFolder1
Else
MsgBox "Impossible de continuer, vous devez choisir le dossier à analyser !", vbCritical, "ARRET de la MACRO"
Exit Sub
End If
' 2ème dossier à analyser
RootFolder2 = Sheets("Accueil").Range("RepComp2").Value
' Choix du dossier à scanner
If RootFolder2 = "" Then RootFolder2 = ChoisirDossier("Choisissez le répertoire n° 2")
If RootFolder2 <> "" Then
Sheets("Accueil").Range("RepComp2").Value = RootFolder2
Else
MsgBox "Impossible de continuer, vous devez choisir le dossier à analyser !", vbCritical, "ARRET de la MACRO"
Exit Sub
End If
' Lister tous les fichiers du dossier 1 et sous-dossier
ListFilesInFolder "Comparatif", RootFolder1, True
' Lister tous les fichiers du dossier 2 et sous-dossier
ListFilesInFolder "Comparatif", RootFolder2, True
' Avec la feuille de comparatif
With Sheets("Comparatif")
' Trier par nom de fichier
DerLig = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:H" & DerLig).Sort Key1:=.Range("B1"), Order1:=xlAscending, _
Key2:=.Range("A1"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
' Faire le comparatif pour chaque fichier
Lig = 2
Do
' Si les 2 lignes qui ce suivent ont le même nom de fichier
If .Range("B" & Lig) = .Range("B" & Lig + 1) Then
' Vérifier les dates pour les 2 fichiers
For Col = 1 To 3
If .Cells(Lig, 3 + Col).Value > .Cells(Lig + 1, 3 + Col).Value Then
.Cells(Lig, 3 + Col).Interior.ColorIndex = IcRec
Msg1 = Msg1 & TpR(Col - 1) & ","
'If Col = 2 Then .Range("H" & Lig).Value = "Plus récent (date de modification)"
End If
If .Cells(Lig + 1, 3 + Col).Value > .Cells(Lig, 3 + Col).Value Then
.Cells(Lig + 1, 3 + Col).Interior.ColorIndex = IcRec
Msg2 = Msg2 & TpR(Col - 1) & ","
'If Col = 2 Then .Range("H" & Lig).Value = "Plus récent (date de modification)"
End If
Next Col
If Len(Msg1) > 0 Then
Msg1 = Left(Msg1, Len(Msg1) - 1)
.Range("H" & Lig).Value = "Plus récent (" & Msg1 & ")"
Msg1 = ""
End If
If Len(Msg2) > 0 Then
Msg2 = Left(Msg2, Len(Msg2) - 1)
.Range("H" & Lig + 1).Value = "Plus récent (" & Msg2 & ")"
Msg2 = ""
End If
' Incrémenter la ligne
Lig = Lig + 2
Else ' Si sur les 2 lignes le fichier est différent
If .Range("A" & Lig) = RootFolder1 Then
.Range("H" & Lig).Value = "Fichier inexistant dans : " & RootFolder2
Else
.Range("H" & Lig).Value = "Fichier inexistant dans : " & RootFolder1
End If
Lig = Lig + 1
End If
Loop While .Range("A" & Lig).Value <> ""
' Trier par nom complet
.Range("A1:H" & DerLig).Sort Key1:=.Range("C1"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub
Sub ListFilesInFolder(ShtDest As String, SourceFolderName As String, IncludeSubfolders As Boolean)
' http://msdn.microsoft.com/en-us/library/hww8txat(VS.85).aspx
Dim FSO 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim Lig As Long, Ind As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
With Sheets(ShtDest)
' Visualiser l'avancement ou non
If FlgVoir Then .Activate
' Ligne suivante
Lig = .Range("A" & Rows.Count).End(xlUp).Row + 1
Ind = 1
For Each FileItem In SourceFolder.Files
' Visualiser l'avancement ou non
If FlgVoir Then .Range("A" & Lig).Select
' Mettre à jour l'affichage
Application.DisplayStatusBar = True
Application.StatusBar = "Inscription fichier : " & Ind & " sur " & SourceFolder.Files.Count & " - Répertoire : " & SourceFolder.Name
' Inscrire les propriétés de chaque fichier
.Range("A" & Lig).Value = FileItem.ParentFolder
.Range("B" & Lig).Value = FileItem.Name
' Nom complet Path + Nom
.Range("C" & Lig).Value = FileItem.ParentFolder & "\" & FileItem.Name
' Date de création
.Range("D" & Lig).Value = FileItem.DateCreated
' Date de modification
.Range("E" & Lig).Value = FileItem.DateLastModified
' Date d'accès
.Range("F" & Lig).Value = FileItem.DateLastAccessed
' Taille du fichier en Ko
.Range("G" & Lig).Value = Round(FileItem.Size / 1024, 0)
' Nom du dernier Autheur
.Range("J" & Lig).Value = FileItem.Author
' numéro de Ligne suivante
Lig = Lig + 1
Ind = Ind + 1
Next FileItem
' Faire les sous-dossier
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder ShtDest, SubFolder.Path, True
Next SubFolder
End If
End With
' Effacer les variables objet
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Private Function ChoisirDossier(LibTxt As String)
Dim objShell, objFolder, VPath, SecuritySlash
Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, LibTxt, &H1&)
On Error Resume Next
VPath = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
' D'parès une idée de MichelXLD
VPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
End If
If objFolder.Title = "" Then
VPath = ""
End If
' Vérifier si slash à la fin
SecuritySlash = InStr(objFolder.Title, ":")
If SecuritySlash > 0 Then
VPath = Mid(objFolder.Title, SecuritySlash - 1, 2) & ""
End If
' Incrire le répertoire de référence dans la feuille Accueil
Sheets("Accueil").Range("DossierRef").Value = VPath
' Renvoyer le chemin dans la fonction
ChoisirDossier = VPath
' Mettre le FLAG Première fois à VRAI
FlgFirst = True
End Function
Function LigFind(VSearch As String, Sht As String, Col As String)
LigFind = 0 ' Mettre la valeur à ZERO
With Sheets(Sht).Range(Col & ":" & Col)
On Error Resume Next
LigFind = .Find(What:=VSearch, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False).Row
On Error GoTo 0
End With
End Function
?
