J'essaie actuellement de modifier une macro précédemment créée par une autre équipe Elle est capable de récupérer tous les noms de fichiers et les chemins d'accès à partir d'un emplacement spécifique, ce qui est très utile si tous les fichiers s'y trouvent.
Mon problème est que j'essaie d'adapter ce système à un autre domaine où les fichiers sont conservés dans un répertoire "Storage". C'est de là qu'ils partent :
Stockage \ProposalFolder\ (1 de 3 dossiers) \File
le système des 1 ou 3 dossiers permet de les classer en fonction du type de proposition qu'ils contiennent
Projet, prospect ou suspect
J'ai donc besoin d'une macro qui prenne en compte le répertoire Stockage et qui parcourt ensuite chaque sous-dossier Proposition, puis voit dans quel type de dossier le fichier est stocké (si le fichier est dans Projet, les deux autres dossiers seront vides).
Voir ci-dessous
Vue de l'entrepôt
Dossier de proposition
Dossier Projet/prospect/suspect
Voici le code qui reste - je l'ai modifié ici et là
Sub ListFilesInDirectory()
If MsgBox("Are you sure you want to list the files?", vbYesNo) = vbNo Then
End
Else
End If
Select Case MsgBox("Press Yes to retrieve ALL files." & vbNewLine & vbNewLine & "Press No to retrieve *** files only", vbQuestion + vbYesNoCancel + vbDefaultButton1, "Which Do You Want To Retrieve?")
Case vbCancel
End
Case vbNo
***_Option = 1
Case vbYes
***_Option = 2
End Select
Dim counter As Single
counter = Timer
On Error GoTo error_message
Application.StatusBar = "The macro is running. Please wait..."
Application.Calculation = xlCalculationManual
Range("A7:KZ10000").Select
Selection.ClearContents
Cells.FormatConditions.Delete
Range("A1").Select
Application.ScreenUpdating = False
'Populate columns A to C
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet
Dim objSubfolders As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = ActiveSheet
startrow = 7
If IsEmpty(Range("file_directory")) Then
GoTo skip_this
Else
filedir = Range("file_directory").Value
End If
'Get the folder object associated with the directory
Set objFolder = objFSO.GetFolder(filedir)
Set objSubfolders = objFolder.subfolders
'ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
'Loop through the Files collection
If ***_Option = 1 Then
For Each objFile In objFolder.Files
DoEvents
If InStr(UCase(objFile.Name), "****") > 0 Then
ws.Cells(startrow, 1).Value = filedir
' ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
ws.Cells(startrow, 2).Value = objFile.Name
ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name
ws.Cells(startrow, 3).Value = objFile.DateLastModified
startrow = startrow + 1
End If
Next
End If
If ***_Option = 2 Then
For Each objFile In objFolder.Files
DoEvents
ws.Cells(startrow, 1).Value = filedir
' ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
ws.Cells(startrow, 2).Value = objFile.Name
ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name
ws.Cells(startrow, 3).Formula = "=CONCATENATE(" & startrow & "2," & startrow & "3)"
startrow = startrow + 1
Next
' For Each SubFolder In objSubfolders
'
' For Each objFile In objSubfolders.Files
' DoEvents
' ws.Cells(startrow, 1).Value = filedir
'' ws.Cells(startrow, 2).Value = "=HYPERLINK(" & Chr(34) & filedir & "\" & objFile.Name & Chr(34) & "," & Chr(34) & objFile.Name & Chr(34) & ")"
' ws.Cells(startrow, 2).Value = objFile.Name
' ws.Cells(startrow, 2).Hyperlinks.Add ws.Cells(startrow, 2), filedir & "\" & objFile.Name
' ws.Cells(startrow, 3).Value = objFile.DateLastModified
' startrow = startrow + 1
' Next
' Next SubFolder
End If
' For Each SubFolder In SourceFolder.subfolders
' ListFilesInFolder SubFolder.Path, True
' Next SubFolder
'
' If subfolders = True Then
' For Each SubFolder In SourceFolder.subfolders
' ListFilesInFolder SubFolder.Path, True
' Next SubFolder
' End If
skip_this:
Next
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
'Format any potential error files in red
Cells.FormatConditions.Delete
Range("B7:B" & lastrow).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=RIGHT(B7,5)<>"".xlsm"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=LEFT(B7,1)=""~"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = True
'Range("C4").Select
'ActiveCell.FormulaR1C1 = "Date" & Chr(10) & "Modified"
Range("C7:C" & lastrow).Select
Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"
Selection.HorizontalAlignment = xlCenter
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox ("Time taken to list files (hr:min:sec): " & Format((Timer - counter) / 86400, "hh:mm:ss") & vbNewLine & vbNewLine & "Please now do an initial cleanup of the files listed:" & vbNewLine & " 1) Delete any obvious older versions of the files" & vbNewLine & " 2) Files highlighted red are likely to be incorrect and should be deleted")
Exit Sub
error_message:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Range("A7:KZ10000").Select
Selection.ClearContents
Cells.FormatConditions.Delete
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox ("You have entered an incorrect directory path. Please ensure the 3 cells in the Variables tab are showing valid directory paths, or the cells are empty")
End SubCe que je dois faire, c'est lister les fichiers dans les sous-dossiers comme le fait le code "Pour chaque objFile", mais je n'arrive pas à comprendre comment aller plus loin qu'un niveau de sous-dossiers - le code commenté sur les sous-dossiers, c'est moi :/.
Toute aide serait la bienvenue !
