Folder name splitting on ^ and _ signs? XL07

[Dark91zc]

Hello All and thank you.

I am new to programming in excel and have been getting help from one other forum. this is the link to my question on the other forum Changing and adding punctuation in a split macro?. i am trying to learn about the split code a little more in depth.

what i want to know is how can i add more signs or characters to split on?

this is the code i am working with right now and it is splitting into the 3 columns fine.

If InStr(SubFolder.Name, "_") Then
            Elements = Split(SubFolder.Name, "_")
            Cells(r, 1) = Elements(0)
            Cells(r, 2) = Elements(1)
            Cells(r, 3) = Elements(2)
               
    
    '        Cells(r, 2).Formula = FileItem.Size
    '        Cells(r, 3).Formula = FileItem.Type
    '        Cells(r, 4).Formula = FileItem.DateCreated
    '        Cells(r, 5).Formula = FileItem.DateLastAccessed
    '        Cells(r, 6).Formula = FileItem.DateLastModified
    '        Cells(r, 7).Formula = FileItem.Attributes
    '        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
            
            r = r + 1 ' next row number
        End If<code></code><code></code>

But i need it to split on the ^ sign also and add one more column. This is that i came up with but i am getting lost as for what i am not doing correct. (my add might be working against me).

If InStr(SubFolder.Name, "_", "^") Then
            Elements = Split(SubFolder.Name, "_", "^")
            Cells(r, 1) = Elements(0)
            Cells(r, 2) = Elements(1)
            Cells(r, 3) = Elements(2)
            Cells(r, 4) = Elements(3)
               
    
    '        Cells(r, 2).Formula = FileItem.Size
    '        Cells(r, 3).Formula = FileItem.Type
    '        Cells(r, 4).Formula = FileItem.DateCreated
    '        Cells(r, 5).Formula = FileItem.DateLastAccessed
    '        Cells(r, 6).Formula = FileItem.DateLastModified
    '        Cells(r, 7).Formula = FileItem.Attributes
    '        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
            
            r = r + 1 ' next row number
        End If

This is what my complete code looks like right now.

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
Sub ImportFilesInFolder()
    'Workbooks.Add ' create a new workbook for the file list
    ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "Last Name:"
    Range("B3").Formula = "First Name:"
    Range("C3").Formula = "MDR:"
    Range("D3").Formula = "Date of Birth:"
'    Range("E3").Formula = "Date Last Accessed:"
'    Range("F3").Formula = "Date Last Modified:"
'    Range("G3").Formula = "Attributes:"
'    Range("H3").Formula = "Short File Name:"
    Range("A3:H3").Font.Bold = True
    
    Msg = "Select a location containing the files you want to list."
    'Directory = GetDirectory(Msg)
    'list all files included subfolders
    ListFilesInFolder GetDirectory(Msg), True

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Dim Elements As Variant
Dim Temp As String

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("A65536").End(xlUp).Row + 1
    For Each SubFolder In SourceFolder.SubFolders
        ' display file properties
        'Temp = StrReverse(SubFolder.Name)
        'Temp = Right(Temp, Len(Temp) - InStr(Temp, "."))
        'Temp = StrReverse(Temp)
        
        If InStr(SubFolder.Name, "_", "^") Then
            Elements = Split(SubFolder.Name, "_", "^")
            Cells(r, 1) = Elements(0)
            Cells(r, 2) = Elements(1)
            Cells(r, 3) = Elements(2)
            Cells(r, 4) = Elements(3)
               
    
    '        Cells(r, 2).Formula = FileItem.Size
    '        Cells(r, 3).Formula = FileItem.Type
    '        Cells(r, 4).Formula = FileItem.DateCreated
    '        Cells(r, 5).Formula = FileItem.DateLastAccessed
    '        Cells(r, 6).Formula = FileItem.DateLastModified
    '        Cells(r, 7).Formula = FileItem.Attributes
    '        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
            
            r = r + 1 ' next row number
        End If
    Next SubFolder
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.path, True
        Next SubFolder
    End If
    Columns("A:D").AutoFit
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    If x = 0 Then End
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function

I am trying to go from this
DOE^JOHN_12349876_19450125
SUE^JEFF_95157535_19181221
SMITH^LEE_84269713_19631124

to this
[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]last name[/TD]
[TD]first name[/TD]
[TD]mdr[/TD]
[TD]date of birth[/TD]
[/TR]
[TR]
[TD]DOE[/TD]
[TD]JOHN[/TD]
[TD]12349876[/TD]
[TD]19451201[/TD]
[/TR]
[TR]
[TD]JANE[/TD]
[TD]MARY[/TD]
[TD]00560803[/TD]
[TD]19430222[/TD]
[/TR]
</tbody>[/TABLE]

Thanks for the help and sorry for being a newb.

 

[Rick Rothstein]

As you have found out, this does not work...

Elements = Split(SubFolder.Name, "_", "^")

If you do not have too many different symbols to split on, you can simply nest VB's Replace function inside each other to substitute the symbols down to a single common symbol and split on that. Let's say you wanted to split the text on these three symbols... "_", "^", "@". You could do this...

Elements = Split(Replace(Replace(SubFolder.Name, "^", "_"), "@", "_"), "_")

The colored text is used in place of SubFolder.Name and it is where all the delimiter symbols are reduced to a common symbol (the underline symbol in this case) and that temporarily transformed text is split apart using that now common symbol.

 

[Dark91zc]

Thank you Rick. This code has allowed me to progress further on this code but have have hit another couple road blocks.

Here is my current Macro or Code Module

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
Sub ImportFilesInFolder()
    'Workbooks.Add ' create a new workbook for the file list
    ' add headers
    'With Range("A1")
    '    .Formula = "Folder contents:"
    '    .Font.Bold = True
    '    .Font.Size = 12
    'End With
    Range("A1").Formula = "Last Name:"
    Range("B1").Formula = "First Name:"
    Range("C1").Formula = "MDR:"
    Range("D1").Formula = "Date Of Birth:"
'    Range("E1").Formula = "Date Last Accessed:"
'    Range("F1").Formula = "Date Last Modified:"
'    Range("G1").Formula = "Attributes:"
'    Range("H1").Formula = "Short File Name:"
    Range("A1:H1").Font.Bold = True
    
    Msg = "Select a location containing the files you want to list."
    'Directory = GetDirectory(Msg)
    'list all files included subfolders
    ListFilesInFolder GetDirectory(Msg), True

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Dim Elements As Variant
Dim Temp As String

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("A65536").End(xlUp).Row + 1
    For Each SubFolder In SourceFolder.SubFolders
        ' display file properties
        'Temp = StrReverse(SubFolder.Name)
        'Temp = Right(Temp, Len(Temp) - InStr(Temp, "."))
        'Temp = StrReverse(Temp)
        
        If InStr(SubFolder.Name, "_") Then
            Elements = Split(Replace(SubFolder.Name, "^", "_"), "_")
            Cells(r, 1) = Elements(0)
            Cells(r, 2) = Elements(1)
            Cells(r, 3) = Elements(2)
            Cells(r, 4) = Elements(3)
               
    
    '        Cells(r, 2).Formula = FileItem.Size
    '        Cells(r, 3).Formula = FileItem.Type
    '        Cells(r, 4).Formula = FileItem.DateCreated
    '        Cells(r, 5).Formula = FileItem.DateLastAccessed
    '        Cells(r, 6).Formula = FileItem.DateLastModified
    '        Cells(r, 7).Formula = FileItem.Attributes
    '        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
            
            r = r + 1 ' next row number
        End If
    Next SubFolder
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.path, True
        Next SubFolder
    End If
    Columns("A:D").AutoFit
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    If x = 0 Then End
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function

The first one is a Run-time error.
The error I am getting is
Microsoft Visual Basic
Run-time error '9':
Subscript out of range

when i click debug this line of code is highlighted in Yellow

Cells(r, 3) = Elements(2)

It is stopping on a generic folder that does not need to have its name imported into the spread sheet. is there a way to skip this folder by way of code? Reason to skip this folder and one other is that they deal with the database for a different program. The folder name is printer files. The code stops every time at this folder.

The second issue I am having is that on the importing of column D it is only printing # characters. i have tried to get the column to read in this format YYYY/MM/DD. The way it looks in the folder name is like this YYYYMMDD.

I did modify the code from this

Sub ImportFilesInFolder()
    'Workbooks.Add ' create a new workbook for the file list
    ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A3").Formula = "Last Name:"
    Range("B3").Formula = "First Name:"
    Range("C3").Formula = "ID:"
'    Range("D3").Formula = "Date Created:"
'    Range("E3").Formula = "Date Last Accessed:"
'    Range("F3").Formula = "Date Last Modified:"
'    Range("G3").Formula = "Attributes:"
'    Range("H3").Formula = "Short File Name:"
    Range("A3:H3").Font.Bold = True
    
    Msg = "Select a location containing the files you want to list."
    'Directory = GetDirectory(Msg)
    'list all files included subfolders
    ListFilesInFolder GetDirectory(Msg), True

End Sub

To this

Sub ImportFilesInFolder()
    'Workbooks.Add ' create a new workbook for the file list
    ' add headers
    'With Range("A1")
    '    .Formula = "Folder contents:"
    '    .Font.Bold = True
    '    .Font.Size = 12
    'End With
    Range("A3").Formula = "Last Name:"
    Range("B3").Formula = "First Name:"
    Range("C3").Formula = "MDR:"
    Range("D3").Formula = "Date Of Birth:"
'    Range("E3").Formula = "Date Last Accessed:"
'    Range("F3").Formula = "Date Last Modified:"
'    Range("G3").Formula = "Attributes:"
'    Range("H3").Formula = "Short File Name:"
    Range("A3:H3").Font.Bold = True
    
    Msg = "Select a location containing the files you want to list."
    'Directory = GetDirectory(Msg)
    'list all files included subfolders
    ListFilesInFolder GetDirectory(Msg), True

End Sub

I have been trying to figure out where i am going wrong but on the stumped side.

Thank you for the help.

 

[Rick Rothstein]

The first one is a Run-time error.
The error I am getting is
Microsoft Visual Basic
Run-time error '9':
Subscript out of range

when i click debug this line of code is highlighted in Yellow

Cells(r, 3) = Elements(2)

It is stopping on a generic folder that does not need to have its name imported into the spread sheet. is there a way to skip this folder by way of code? Reason to skip this folder and one other is that they deal with the database for a different program. The folder name is printer files. The code stops every time at this folder.

You might try adding the colored code lines in this part of your code...

If InStr(SubFolder.Name, "_") Then
            Elements = Split(Replace(SubFolder.Name, "^", "_"), "_")
            If UBound(Elements) = 3 Then
                Cells(r, 1) = Elements(0)
                Cells(r, 2) = Elements(1)
                Cells(r, 3) = Elements(2)
                Cells(r, 4) = Elements(3)
               
    
    '        Cells(r, 2).Formula = FileItem.Size
    '        Cells(r, 3).Formula = FileItem.Type
    '        Cells(r, 4).Formula = FileItem.DateCreated
    '        Cells(r, 5).Formula = FileItem.DateLastAccessed
    '        Cells(r, 6).Formula = FileItem.DateLastModified
    '        Cells(r, 7).Formula = FileItem.Attributes
    '        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
            
                r = r + 1 ' next row number
          End If
      End If

The second issue I am having is that on the importing of column D it is only printing # characters.

That usually indicates the column is not wide enough to display everything it must display. Try widening the column and see that solves the problem/

 

[Dark91zc]

Thanks again Rick. Awesome. As for making the column wider the first to row printed the date of birth correct but at the 3rd row and down it printed # in the D column from 4 on down. I made the cell 1000 pixels wide and same thing.

This is my current code

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
Sub ImportFilesInFolder()
    'Workbooks.Add ' create a new workbook for the file list
    ' add headers
  [COLOR=#b22222]  'With Range("A1")
    '    .Formula = "Folder contents:"
    '    .Font.Bold = True
    '    .Font.Size = 12
    'End With[/COLOR]
    [COLOR=#b22222]Range("A1").Formula = "Last Name:"
    Range("B1").Formula = "First Name:"
    Range("C1").Formula = "MDR:"
    Range("D1").Formula = "Date Of Birth:"
'    Range("E1").Formula = "Date Last Accessed:"
'    Range("F1").Formula = "Date Last Modified:"
'    Range("G1").Formula = "Attributes:"
'    Range("H1").Formula = "Short File Name:"
    Range("A1:H1").Font.Bold = True[/COLOR]
    
    Msg = "Select a location containing the files you want to list."
    'Directory = GetDirectory(Msg)
    'list all files included subfolders
    ListFilesInFolder GetDirectory(Msg), True

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Dim Elements As Variant
Dim Temp As String

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("A65536").End(xlUp).Row + 1
    For Each SubFolder In SourceFolder.SubFolders
        ' display file properties
        'Temp = StrReverse(SubFolder.Name)
        'Temp = Right(Temp, Len(Temp) - InStr(Temp, "."))
        'Temp = StrReverse(Temp)
        
        If InStr(SubFolder.Name, "_") Then
             Elements = Split(Replace(SubFolder.Name, "^", "_"), "_")
            If UBound(Elements) = 3 Then
                Cells(r, 1) = Elements(0)
                Cells(r, 2) = Elements(1)
                Cells(r, 3) = Elements(2)
                Cells(r, 4) = Elements(3)
               
    
    '        Cells(r, 2).Formula = FileItem.Size
    '        Cells(r, 3).Formula = FileItem.Type
    '        Cells(r, 4).Formula = FileItem.DateCreated
    '        Cells(r, 5).Formula = FileItem.DateLastAccessed
    '        Cells(r, 6).Formula = FileItem.DateLastModified
    '        Cells(r, 7).Formula = FileItem.Attributes
    '        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
            
                r = r + 1 ' next row number
          End If
      End If
    Next SubFolder
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.path, True
        Next SubFolder
    End If
    [COLOR=#b22222]Columns("A:D").AutoFit[/COLOR]
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    If x = 0 Then End
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function

In the parts of the code I colored I made the following changes
Starting with "Wide Range and ending at End" i added a ' infront so it would not add that part into the spread sheet. Could this section of code be deleted?
The lines of code with Range in front I change 3 to 1 so it would read from the first row. in the Range C1 and D1 i change the name that would be printed on the spread sheet. The Range code that has D1 in it i removed the ' character. The last Range I changed the 3's to 1's.
In the last code that has Columns i changed the A:C to A:D.

Sofar it is working great just minor things I need to figure out thank you

 

[Dark91zc]

So I did some more poking around with the code and ended up getting it to work the way i wanted. Thank you so much for your help Rick. I have one final question for this code. how can i add in a date covert from D2 and beyond? i want to have it go from looking like this YYYYMMDD to looking like MM/DD/YYYY. I have tried doing the format cell method and all I end up with is ####### across D column. I have tried some other scripts and end up with a #!VALUE!# error.
This is the script i was trying

Sub ConvertDates()
Dim rRange As Range
'[COLOR=YellowGreen] 'Set range to data cells only[/COLOR]
Set rRange = Range("D2", Range("A65536").End(xlUp))
'[COLOR=YellowGreen] 'Insert spare Column.[/COLOR]
With rRange 'With Range Object
    '[COLOR=YellowGreen] 'Add a column for functions[/COLOR]
    .EntireColumn.Insert
    '[COLOR=YellowGreen] 'Insert the Functions as relative. May need replacing![/COLOR]
    .Offset(0, -1).FormulaR1C1 = _
    "=VALUE(MID(RC[1],3,2)&""/""&LEFT(RC[1],2)&""/""&RIGHT(RC[1],2))"
    '[COLOR=YellowGreen] 'Covert to values only and date format[/COLOR]
    .Offset(0, -1) = .Offset(0, -1).Value
    .Offset(0, -1).NumberFormat = "dd/mm/yy"
    '[COLOR=YellowGreen] 'Delete the original data[/COLOR]
    .EntireColumn.Delete
End With
 
End Sub

If i have to run it by itself that is fine.

Here is my code that we have been working on. Thanks again.

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
Sub ImportFilesInFolder()
    'Workbooks.Add ' create a new workbook for the file list
    ' add headers
    'With Range("A1")
    '    .Formula = "Folder contents:"
    '    .Font.Bold = False
    '    .Font.Size = 12
    'End With
    Range("A1").Formula = "Last Name:"
    Range("B1").Formula = "First Name:"
    Range("C1").Formula = "MDR:"
    Range("D1").Formula = "Date Of Birth:"
'    Range("E1").Formula = "Date Last Accessed:"
'    Range("F1").Formula = "Date Last Modified:"
'    Range("G1").Formula = "Attributes:"
'    Range("H1").Formula = "Short File Name:"
    Range("A1:H1").Font.Bold = True
    Msg = "Select a location containing the folders you want to list."
    'Directory = GetDirectory(Msg)
    'list all files included subfolders
    ListFilesInFolder GetDirectory(Msg), True

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Dim Elements As Variant
Dim Temp As String

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    r = Range("A65536").End(xlUp).Row + 1
    For Each SubFolder In SourceFolder.SubFolders
        ' display file properties
        'Temp = StrReverse(SubFolder.Name)
        'Temp = Right(Temp, Len(Temp) - InStr(Temp, "."))
        'Temp = StrReverse(Temp)
        
        If InStr(SubFolder.Name, "_") Then
             Elements = Split(Replace(SubFolder.Name, "^", "_"), "_")
            If UBound(Elements) = 3 Then
                Cells(r, 1) = Elements(0)
                Cells(r, 2) = Elements(1)
                Cells(r, 3) = Elements(2)
                Cells(r, 4) = Elements(3)
               
    
    '        Cells(r, 2).Formula = FileItem.Size
    '        Cells(r, 3).Formula = FileItem.Type
    '        Cells(r, 4).Formula = FileItem.DateCreated
    '        Cells(r, 5).Formula = FileItem.DateLastAccessed
    '        Cells(r, 6).Formula = FileItem.DateLastModified
    '        Cells(r, 7).Formula = FileItem.Attributes
    '        Cells(r, 8).Formula = FileItem.ShortPath & FileItem.ShortName
            
                r = r + 1 ' next row number
          End If
      End If
    Next SubFolder
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.path, True
        Next SubFolder
    End If
    Columns("A:D").AutoFit
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
End Sub


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    If x = 0 Then End
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function