Need to take a lot of care when modifying lots of files automatically
Here are 2 subs to verify that the correct files and folders are being selected
- run the first sub (to create folder list in sheet F1) with: {CTRL} k
- delete any folders not wanted from F1 with {DEL}
- empty rows are OK
- next run 2nd macro (to create list of all files in those folders in sheet F2) with: {CTRL} {SHIFT} k
When the list in F2 is correct, that list can be used to amend the files
amend this to the correct top folder
topfolder = "C:\Users\roineo\Desktop\New folder (3)\New folder"
amend sub-layers
with SubLayers = 4, folders listed down to: TopFolder\SubFolders\Sub-SubFolders\Sub-SubSubFolders
Dim objFSO As Object, objFolder As Object, objSubFolder As Object
Dim i As Integer, x As Integer, SubLayers As Integer, fr As Long, lr As Long
Dim cel As Range, rng As Range
Sub ListFoldersSubFoldersSubFolders() 'run with {CTRL} k
topfolder = "C:\Users\roineo\Desktop\New folder (3)\New folder"
SubLayers = 4
i = 1: x = 0: fr = 1
Sheets("F1").Activate
Cells(1, 1).Value = topfolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do Until x = SubLayers
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range(Cells(fr, 1), Cells(lr, 1))
For Each cel In rng
On Error Resume Next
Set objFolder = objFSO.GetFolder(cel.Value)
For Each objSubFolder In objFolder.subfolders
Cells(i + 1, 1) = objSubFolder.Path
i = i + 1
Next objSubFolder
Next cel
x = x + 1
fr = lr + 1
Loop
End Sub
Sub ListFilesInListedFolder() 'run with {CTRL} {SHIFT} k
Set objFSO = CreateObject("Scripting.FileSystemObject")
With Sheets("F1")
Set rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
End With
i = 0
Sheets("F2").Activate
For Each cel In rng
On Error Resume Next
Set objFolder = objFSO.GetFolder(cel.Value)
For Each objFile In objFolder.Files
Cells(i + 1, 2) = objFile.Name
Cells(i + 1, 1) = objFile.Path
i = i + 1
Next objFile
Next cel
End Sub
LinkBack URL
About LinkBacks
Register To Reply
)
Bookmarks