Is there a way to get Specific subfolder level names and put in a column

I am using the following code to maintain a list of files in a specific server directory. We use this list as a Table of Contents and the sub folder names are based on Manufacture and then Type. We now have some additional classifications that we want to use under each type that can create additional subfolders. If those additional subfolders get created, the columns on the TOC that match to the Type and the Manufacture will no longer work as coded. Is there a way to program it to always get the 6th and 7th folder from the File Path and put them in the columns that they are associated with so that if the Type subfolder ends up with additional subfolders, the TOC with always display the Manufacture and Type for that particular file? See Lines 17, 18, 20-23 of attached file. The folders listed are not the Manufacture and Type, They are Type and Sub Type.

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, lr As Long, Filename As Range
     Dim ws1 As Worksheet, d As Date, NewFile As Range
     
     Set ws1 = ThisWorkbook.Sheets("Sheet1")
     lr = ws1.Range("B" & Rows.Count).End(xlUp).Row
     Set Filename = ws1.Range("B2:B" & lr)
     
     '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
     'Look for New Files
        With ws1.Range("B2:B" & lr)
                Set NewFile = .Find(What:=objFile.Name, _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
            If NewFile Is Nothing Then
                    ws1.Cells(NextRow, "B").Value = objFile.Name
                        ws1.Cells(NextRow, "B").Select
                        ws1.Hyperlinks.Add Anchor:=Selection, Address:=(objFile.Path), TextToDisplay:=Selection.Text
                    ws1.Cells(NextRow, "C").Value = objFile.DateCreated
                    ws1.Cells(NextRow, "D").Value = objFolder.Name
                    ws1.Cells(NextRow, "E").Value = objFolder.ParentFolder.Name
                    
                    NextRow = NextRow + 1
            End If
        End With
    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
     
    Call Sort
     
End Sub

Thanks Keebellah, that looks like it did the trick.

One more thing, as I was getting ready to mark this solved they asked for an additional column. Each file name begins with a part number that is followed by a -. Would I be able to use another array to parse out the part number between "\" and "-"?

Path example \\File Server\Files\Main Folder\Department\Library\Mechanical\Manufacture\Type\012345 - Part Description.dwg

Keebellah,
I figured out my add on question using your split method, but this time I just split the File Name only so I did not have to worry about multiple parameters. Thanks a lot for the help on the split function I had not used that before.

Final code is below

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, lr As Long, Filename As Range
     Dim ws1 As Worksheet, NewFile As Range
     Dim Foldstring As String, Namestring As String, foldArr As Variant, nameArr As Variant
     
     Set ws1 = ThisWorkbook.Sheets("Sheet1")
     lr = ws1.Range("B" & Rows.Count).End(xlUp).Row
     Set Filename = ws1.Range("B2:B" & lr)
     
     '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
        With ws1.Range("B2:B" & lr)
                Set NewFile = .Find(What:=objFile.Name, _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
            If NewFile Is Nothing Then
                Namestring = objFile.Name
                nameArr = (Split(Namestring, " - "))
                    ws1.Cells(NextRow, "E").Value = nameArr(LBound(nameArr))
                    ws1.Cells(NextRow, "B").Value = objFile.Name
                        ws1.Cells(NextRow, "B").Select
                        ws1.Hyperlinks.Add Anchor:=Selection, Address:=(objFile.Path), TextToDisplay:=Selection.Text
                    Foldstring = objFile.Path
                    foldArr = (Split(Foldstring, "\"))
                        ws1.Cells(NextRow, "C").Value = foldArr(LBound(foldArr) + 8)    'objFolder.Name
                        ws1.Cells(NextRow, "D").Value = foldArr(LBound(foldArr) + 7)    'objFolder.ParentFolder.Name
                    
                    NextRow = NextRow + 1
            End If
        End With
    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
     
    Call Sort
     
End Sub