Happy valentines day
I need help to modify this Macro: This macro runs automatically when workbook open. and it hyperlink all my file in desktop.
I need:
1) To run Macro Manually.
2) Selection Folder Location.
VBA:
'Force the explicit delcaration of variables
Option Explicit
Sub ListFiles()
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
'Insert the headers for Columns A through F
Range("B1").Value = "File Name"
Range("C1").Value = "Folder Name"
Range("D1").Value = "Date Created"
Range("E1").Value = "Date Last Modified"
' Range("F1").Value = "Date Last Accessed"
' Range("G1").Value = "File Type"
' Range("H1").Value = "File Size"
'Assign the top folder to a variable
' strTopFolderName = "C:\Users\cafe.CAKESANDBAKES\Desktop\Recipes List"
strTopFolderName = ActiveWorkbook.Path & "\"
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)
'Change the width of the columns to achieve the best fit
' Columns.AutoFit
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long
'Find the next available row
NextRow = Cells(Rows.Count, "B").End(xlUp).Row + 1
'Loop through each file in the folder
For Each objFile In objFolder.Files
' Cells(NextRow, "A").Value = objFile.Name
' If objFile.Name <> ActiveWorkbook.Name And objFile.Name <> "~$" & ActiveWorkbook.Name Then
If objFile.Name <> ActiveWorkbook.Name And Not objFile.Name Like "~$*" Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(NextRow, "B"), Address:= _
objFile.Path, TextToDisplay:=objFile.Name
ActiveSheet.Cells(NextRow, "C") = objFolder.Name
ActiveSheet.Cells(NextRow, "D") = objFile.DateCreated
ActiveSheet.Cells(NextRow, "E") = objFile.DateLastModified
' ActiveSheet.Cells(NextRow, "F") = objFile.DateLastAccessed
' ActiveSheet.Cells(NextRow, "G") = objFile.Type
' ActiveSheet.Cells(NextRow, "H") = objFile.Size
' Cells(NextRow, "B").Value = objFile.Size
' Cells(NextRow, "C").Value = objFile.Type
' Cells(NextRow, "D").Value = objFile.DateCreated
' Cells(NextRow, "E").Value = objFile.DateLastAccessed
' Cells(NextRow, "F").Value = objFile.DateLastModified
NextRow = NextRow + 1
End If
Next objFile
'Loop through files in the subfolders
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If
End Sub
I need help to modify this Macro: This macro runs automatically when workbook open. and it hyperlink all my file in desktop.
I need:
1) To run Macro Manually.
2) Selection Folder Location.
VBA:
'Force the explicit delcaration of variables
Option Explicit
Sub ListFiles()
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
'Insert the headers for Columns A through F
Range("B1").Value = "File Name"
Range("C1").Value = "Folder Name"
Range("D1").Value = "Date Created"
Range("E1").Value = "Date Last Modified"
' Range("F1").Value = "Date Last Accessed"
' Range("G1").Value = "File Type"
' Range("H1").Value = "File Size"
'Assign the top folder to a variable
' strTopFolderName = "C:\Users\cafe.CAKESANDBAKES\Desktop\Recipes List"
strTopFolderName = ActiveWorkbook.Path & "\"
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)
'Change the width of the columns to achieve the best fit
' Columns.AutoFit
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long
'Find the next available row
NextRow = Cells(Rows.Count, "B").End(xlUp).Row + 1
'Loop through each file in the folder
For Each objFile In objFolder.Files
' Cells(NextRow, "A").Value = objFile.Name
' If objFile.Name <> ActiveWorkbook.Name And objFile.Name <> "~$" & ActiveWorkbook.Name Then
If objFile.Name <> ActiveWorkbook.Name And Not objFile.Name Like "~$*" Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(NextRow, "B"), Address:= _
objFile.Path, TextToDisplay:=objFile.Name
ActiveSheet.Cells(NextRow, "C") = objFolder.Name
ActiveSheet.Cells(NextRow, "D") = objFile.DateCreated
ActiveSheet.Cells(NextRow, "E") = objFile.DateLastModified
' ActiveSheet.Cells(NextRow, "F") = objFile.DateLastAccessed
' ActiveSheet.Cells(NextRow, "G") = objFile.Type
' ActiveSheet.Cells(NextRow, "H") = objFile.Size
' Cells(NextRow, "B").Value = objFile.Size
' Cells(NextRow, "C").Value = objFile.Type
' Cells(NextRow, "D").Value = objFile.DateCreated
' Cells(NextRow, "E").Value = objFile.DateLastAccessed
' Cells(NextRow, "F").Value = objFile.DateLastModified
NextRow = NextRow + 1
End If
Next objFile
'Loop through files in the subfolders
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If
End Sub