Macro to List or Fetch all the details of Files and SubFolders with Files from a Folder or Specific Path
Sub List_All_SubFolders_Files()
Dim SrcPath As String
Dim FSO As Object
Dim SrcFolder As Object
Dim S_Folder As Object
Dim S_File As Object
Dim FileExt As String
Dim WS As Object
SrcPath = ActiveSheet.Range("B1").Value
Set WS = ThisWorkbook.ActiveSheet
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SrcFolder = FSO.GetFolder(SrcPath)
If Right(SrcPath, 1) = "\" Then
SrcPath = Left(SrcPath, Len(SrcPath) - 1)
End If
If (SrcFolder.Files.Count = 0) And (SrcFolder.SubFolders.Count = 0) Then
MsgBox "Src Folder Doesnot Have Any Subfolders/Files", vbOKCancel,
"Src Folder Is Empty"
Exit Sub
End If
ActiveSheet.Range("A3:G1000").Select
Selection.Clear
Z = 0
K = 3
MFC = SrcFolder.Files.Count 'Main Folder Files Count
WS.Cells(K, 1) = SrcFolder.Name
WS.Cells(K, 1).Interior.ColorIndex = 37
WS.Cells(K, 1).Font.Bold = True
WS.Cells(K, 2) = SrcFolder.Path
WS.Cells(K, 3) = Round(SrcFolder.Size / 1024) & " KB"
WS.Cells(K, 4) = SrcFolder.Type
WS.Cells(K, 5) = SrcFolder.DateLastModified
WS.Cells(K, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
SrcFolder.Path, TextToDisplay:="Click Here to Open"
If (Round((SrcFolder.Size / 1024) / 1024) = 0) Then
WS.Cells(K, 7) = "<1 MB"
Else
WS.Cells(K, 7) = Round((SrcFolder.Size / 1024) / 1024) & " MB"
End If
K = K + 1
For Y = K To MFC
For Each File In SrcFolder.Files
M_File_Name = File.Name
M_File_Path = File.Path
M_File_Size = Round(File.Size / 1024) & " KB"
If (Round((File.Size / 1024) / 1024) = 0) Then
MB_File_Size = "<1 MB"
Else
MB_File_Size = Round((File.Size / 1024) / 1024) & " MB"
End If
M_File_Type = File.Type
M_File_Modified = File.DateLastModified
WS.Cells(Y, 1) = M_File_Name
WS.Cells(Y, 2) = M_File_Path
WS.Cells(Y, 3) = M_File_Size
WS.Cells(Y, 4) = M_File_Type
WS.Cells(Y, 5) = M_File_Modified
WS.Cells(Y, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
M_File_Path, TextToDisplay:="Click Here to Open"
WS.Cells(Y, 7) = MB_File_Size
Y = Y + 1
Z = Z + 1
Next File
Next Y
K = K + Z
If (SrcFolder.SubFolders.Count > 0) Then
For Each SubFolder In SrcFolder.SubFolders
If (SubFolder.Files.Count > 0) Then
S_Folder_Name = SubFolder.Name
S_Folder_Path = SubFolder.Path
S_Folder_Size = Round(SubFolder.Size / 1024) & " KB"
If (Round((SubFolder.Size / 1024) / 1024) = 0) Then
SMB_Folder_Size = "<1 MB"
Else
SMB_Folder_Size = Round((SubFolder.Size / 1024) / 1024) & " MB"
End If
S_Folder_Type = SubFolder.Type
S_Folder_Modified = SubFolder.DateLastModified
SFC = SubFolder.Files.Count ' Sub Folder Files Count
For X = K To (K + SFC)
WS.Cells(X, 1) = S_Folder_Name
WS.Cells(X, 1).Interior.ColorIndex = 36
WS.Cells(X, 1).Font.Bold = True
WS.Cells(X, 2) = S_Folder_Path
WS.Cells(X, 3) = S_Folder_Size
WS.Cells(X, 4) = S_Folder_Type
WS.Cells(X, 5) = S_Folder_Modified
WS.Cells(X, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
S_Folder_Path, TextToDisplay:="Click Here to Open"
WS.Cells(X, 7) = SMB_Folder_Size
For Each File In SubFolder.Files
X = X + 1
S_File_Name = File.Name
S_File_Path = File.Path
S_File_Size = Round(File.Size / 1024) & " KB"
If (Round((File.Size / 1024) / 1024) = 0) Then
SMB_File_Size = "<1 MB"
Else
SMB_File_Size = Round((File.Size / 1024) / 1024) & " MB"
End If
S_File_Type = File.Type
S_File_Modified = File.DateLastModified
WS.Cells(X, 1) = S_File_Name
WS.Cells(X, 2) = S_File_Path
WS.Cells(X, 3) = S_File_Size
WS.Cells(X, 4) = S_File_Type
WS.Cells(X, 5) = S_File_Modified
WS.Cells(X, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
S_File_Path, TextToDisplay:="Click Here to Open"
WS.Cells(X, 7) = SMB_File_Size
K = K + 1
Next File
K = K + 1
Next X
End If
Next SubFolder
End If
Set FSO = Nothing
End Sub
Sub List_All_SubFolders_Files()
Dim SrcPath As String
Dim FSO As Object
Dim SrcFolder As Object
Dim S_Folder As Object
Dim S_File As Object
Dim FileExt As String
Dim WS As Object
SrcPath = ActiveSheet.Range("B1").Value
Set WS = ThisWorkbook.ActiveSheet
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SrcFolder = FSO.GetFolder(SrcPath)
If Right(SrcPath, 1) = "\" Then
SrcPath = Left(SrcPath, Len(SrcPath) - 1)
End If
If (SrcFolder.Files.Count = 0) And (SrcFolder.SubFolders.Count = 0) Then
MsgBox "Src Folder Doesnot Have Any Subfolders/Files", vbOKCancel,
"Src Folder Is Empty"
Exit Sub
End If
ActiveSheet.Range("A3:G1000").Select
Selection.Clear
Z = 0
K = 3
MFC = SrcFolder.Files.Count 'Main Folder Files Count
WS.Cells(K, 1) = SrcFolder.Name
WS.Cells(K, 1).Interior.ColorIndex = 37
WS.Cells(K, 1).Font.Bold = True
WS.Cells(K, 2) = SrcFolder.Path
WS.Cells(K, 3) = Round(SrcFolder.Size / 1024) & " KB"
WS.Cells(K, 4) = SrcFolder.Type
WS.Cells(K, 5) = SrcFolder.DateLastModified
WS.Cells(K, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
SrcFolder.Path, TextToDisplay:="Click Here to Open"
If (Round((SrcFolder.Size / 1024) / 1024) = 0) Then
WS.Cells(K, 7) = "<1 MB"
Else
WS.Cells(K, 7) = Round((SrcFolder.Size / 1024) / 1024) & " MB"
End If
K = K + 1
For Y = K To MFC
For Each File In SrcFolder.Files
M_File_Name = File.Name
M_File_Path = File.Path
M_File_Size = Round(File.Size / 1024) & " KB"
If (Round((File.Size / 1024) / 1024) = 0) Then
MB_File_Size = "<1 MB"
Else
MB_File_Size = Round((File.Size / 1024) / 1024) & " MB"
End If
M_File_Type = File.Type
M_File_Modified = File.DateLastModified
WS.Cells(Y, 1) = M_File_Name
WS.Cells(Y, 2) = M_File_Path
WS.Cells(Y, 3) = M_File_Size
WS.Cells(Y, 4) = M_File_Type
WS.Cells(Y, 5) = M_File_Modified
WS.Cells(Y, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
M_File_Path, TextToDisplay:="Click Here to Open"
WS.Cells(Y, 7) = MB_File_Size
Y = Y + 1
Z = Z + 1
Next File
Next Y
K = K + Z
If (SrcFolder.SubFolders.Count > 0) Then
For Each SubFolder In SrcFolder.SubFolders
If (SubFolder.Files.Count > 0) Then
S_Folder_Name = SubFolder.Name
S_Folder_Path = SubFolder.Path
S_Folder_Size = Round(SubFolder.Size / 1024) & " KB"
If (Round((SubFolder.Size / 1024) / 1024) = 0) Then
SMB_Folder_Size = "<1 MB"
Else
SMB_Folder_Size = Round((SubFolder.Size / 1024) / 1024) & " MB"
End If
S_Folder_Type = SubFolder.Type
S_Folder_Modified = SubFolder.DateLastModified
SFC = SubFolder.Files.Count ' Sub Folder Files Count
For X = K To (K + SFC)
WS.Cells(X, 1) = S_Folder_Name
WS.Cells(X, 1).Interior.ColorIndex = 36
WS.Cells(X, 1).Font.Bold = True
WS.Cells(X, 2) = S_Folder_Path
WS.Cells(X, 3) = S_Folder_Size
WS.Cells(X, 4) = S_Folder_Type
WS.Cells(X, 5) = S_Folder_Modified
WS.Cells(X, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
S_Folder_Path, TextToDisplay:="Click Here to Open"
WS.Cells(X, 7) = SMB_Folder_Size
For Each File In SubFolder.Files
X = X + 1
S_File_Name = File.Name
S_File_Path = File.Path
S_File_Size = Round(File.Size / 1024) & " KB"
If (Round((File.Size / 1024) / 1024) = 0) Then
SMB_File_Size = "<1 MB"
Else
SMB_File_Size = Round((File.Size / 1024) / 1024) & " MB"
End If
S_File_Type = File.Type
S_File_Modified = File.DateLastModified
WS.Cells(X, 1) = S_File_Name
WS.Cells(X, 2) = S_File_Path
WS.Cells(X, 3) = S_File_Size
WS.Cells(X, 4) = S_File_Type
WS.Cells(X, 5) = S_File_Modified
WS.Cells(X, 6).Select
WS.Hyperlinks.Add Anchor:=Selection, Address:= _
S_File_Path, TextToDisplay:="Click Here to Open"
WS.Cells(X, 7) = SMB_File_Size
K = K + 1
Next File
K = K + 1
Next X
End If
Next SubFolder
End If
Set FSO = Nothing
End Sub
--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------
No comments:
Post a Comment
Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.