Macro Modification help?

F

FGaxha

Board Regular
Joined
Jan 10, 2023
Messages
221
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

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Sort by date Sort by votes
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
HaHoBe said:
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
Click to expand...

HaHoBe,
YES, it works great.
I deactivate "Workbook_Open in ThisWorkbook"
Thank You and have a grate day
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Retrieving file attributes
Replies
1
Views
195
jkpieterse
jkpieterse
K
  • Question
How to list folder content based on file types?
Replies
2
Views
739
kindlysinful69
K
M
  • Solved
VBA Excel file attributes
2
Replies
13
Views
335
mrsushi
M
D
  • Question
Take text string from cell into VBA code and use it?
Replies
2
Views
475
DJT80
D
K
  • Question
VBA listing ".xlsx" files only from a selected folder
Replies
3
Views
1K
HaHoBe
HaHoBe

Forum statistics

Threads
1,214,625
Messages
6,120,598
Members
448,973
Latest member
ksonnia

Share this page

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