• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 323
  • Last Modified:

How to mofify this VBA sprea sheet for my needs

Hello guys,
What I'd like to do is modify this macro because what I like to obtain is: for example I have one path like \\servername\folder\subfolder\subfolder\file into a column,row(A1) and I'd like to set it up as variable instead of choosing the path manually by browsing the folders. How can I modify the code in the attachment below? Any help will be appreciate, but if you could tell me exactly what to do it's better!!! :) thanks in advance
Option Explicit
Sub PopulateDirectoryList()
'dimension variables
Dim objFSO As FileSystemObject, objFolder As Folder
Dim objFile As File, strSourceFolder As String, x As Long, i As Long
Dim wbNew As Workbook, wsNew As Worksheet

ToggleStuff False 'turn of screenupdating

Set objFSO = New FileSystemObject  'set a new object in memory
strSourceFolder = BrowseForFolder 'call up the browse for folder routine
If strSourceFolder = "" Then Exit Sub

Workbooks.Add 'create a new workbook

Set wbNew = ActiveWorkbook
Set wsNew = wbNew.Sheets(1) 'set the worksheet
'format a header
With wsNew.Range("A1:F1")
    .Value = Array("File", "Size", "Modified Date", "Last Accessed", "Created Date", "Full Path", "Size")
    .Interior.ColorIndex = 7
    .Font.Bold = True
    .Font.Size = 12
End With

With Application.FileSearch
    .LookIn = strSourceFolder  'look in the folder browsed to
    .FileType = msoFileTypeAllFiles 'get all files
    .SearchSubFolders = True  'search sub directories
    .Execute  'run the search
    For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
       i = x 'make the variable i = x
       If x > 60000 Then  'if there happens to be more than multipls of 60,000 files, then add a new sheet
          i = x - 60000  'set i to the right number for row placement below
          Set wsNew = wbNew.Sheets.Add(after:=Sheets(wsNew.Index))
          With wsNew.Range("A1:F1")
            .Value = Array("File", "Parent Folder", "Full Path", "Modified Date", _
                                               "Last Accessed", "Size")
            .Interior.ColorIndex = 7
            .Font.Bold = True
            .Font.Size = 12
           End With

       End If
        On Error GoTo Skip 'in the event of a permissions error
        Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
         With wsNew.Cells(1, 1) 'populate the next row with the variable data
             .Offset(i, 0) = objFile.Name
             .Offset(i, 1) = Format(objFile.Size, "0,000") & " KB"
             .Offset(i, 2) = objFile.DateLastModified
             .Offset(i, 3) = objFile.DateLastAccessed
             .Offset(i, 4) = objFile.DateCreated
             .Offset(i, 5) = objFile.Path
         End With
          ' Next objFile
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
     Next x

End With

'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing
ToggleStuff True 'turn events back on
End Sub
Sub ToggleStuff(ByVal x As Boolean)
Application.ScreenUpdating = x
Application.EnableEvents = x
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    '''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
        End Select
    Exit Function

ToggleStuff True
End Function

Open in new window

1 Solution
>>have one path like \\servername\folder\subfolder\subfolder\file into a column,row(A1) and I'd like to set it up as variable instead of choosing the path manually by browsing the folders.

I believe all you need to do is change line 11, for quick validation.  Instead of calling the BrowseForFolder function, just pull the folder from A1 (assumes the folder is in the workbook where you're writing your macros?

dim wkb as workbook
dim sht as worksheet

  set wkb = ThisWorkbook 'change as necessar
  set sht = ThisWorkbook.ActiveSheet 'or Thisworkbook.Sheets("whatever")

   strSourceFolder = sht.Range("A1").value

Let me know if this help!

I answered a similar question earlier -

I would create a macro/function:

1) access the Macro IDE with Alt+F11
2) insert a new module - Insert - Module
3) insert a new function - Insert - Procedure - type "GetFileProperty"and click type "Function" click on OK

Then replace the function with this:

Public Function GetFileProperty(myFile As String, myType As String) As String

    'This creates an instance of the MS Scripting Runtime FileSystemObject class
    Set oFS = CreateObject("Scripting.FileSystemObject")

    Select Case UCase(Trim(myType))
        Case "CREATED"
            GetFileProperty = oFS.GetFile(myFile).DateCreated
        Case "MODIFIED"
            GetFileProperty = oFS.GetFile(myFile).DateLastModified
        Case "ACCESSED"
            GetFileProperty = oFS.GetFile(myFile).DateLastAccessed
        Case "SIZE"
            GetFileProperty = oFS.GetFile(myFile).Size
        Case Else
            GetFileProperty = "#Need Type#"
    End Select
End Function

To use the function - in Column  A = you would have your list of files, then

just use the function in the appropriate columns:
nassio1985Author Commented:
Thanks sorry if I posted again
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now