Macro Modification help?

FGaxha

Board Regular
Joined
Jan 10, 2023
Messages
227
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Hi FGaxha,

in the future please use code-tags to present your code here - see How to Post Your VBA Code.

The procedure might get called from Workbook_Open in ThisWorkbook but you can start it manually anytime as it is no event code.

For choosing a folder code may look like

VBA Code:
Sub ListFiles_mod()

'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


'Assign the top folder to a variable
' strTopFolderName = "C:\Users\cafe.CAKESANDBAKES\Desktop\Recipes List"
strTopFolderName = ActiveWorkbook.Path & "\"
With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = ActiveWorkbook.Path & "\"
  .AllowMultiSelect = False
  .ButtonName = "FolderPicker"
  If .Show = -1 Then
    strTopFolderName = .SelectedItems(1) & "\"
  Else
    Exit Sub
  End If
End With
'if len(str,

'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"

'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

Code should be placed in a standard module.

Ciao,
Holger
 
Upvote 1
Hi FGaxha,

in the future please use code-tags to present your code here - see How to Post Your VBA Code.

The procedure might get called from Workbook_Open in ThisWorkbook but you can start it manually anytime as it is no event code.

For choosing a folder code may look like

VBA Code:
Sub ListFiles_mod()

'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


'Assign the top folder to a variable
' strTopFolderName = "C:\Users\cafe.CAKESANDBAKES\Desktop\Recipes List"
strTopFolderName = ActiveWorkbook.Path & "\"
With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = ActiveWorkbook.Path & "\"
  .AllowMultiSelect = False
  .ButtonName = "FolderPicker"
  If .Show = -1 Then
    strTopFolderName = .SelectedItems(1) & "\"
  Else
    Exit Sub
  End If
End With
'if len(str,

'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"

'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

Code should be placed in a standard module.

Ciao,
Holger

HaHoBe,
YES, it works great.
I deactivate "Workbook_Open in ThisWorkbook"
Thank You and have a grate day
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top