Este código transfiere nombres de archivos de una carpeta. ¿Cómo se agregan varias rutas de archivos para que pueda transferir nombres de archivos de varias carpetas?

 Sub get_files() Dim FsysObj As Object Dim objFolder As Object Dim objFiles As Object Dim SplitArray() As String Dim ID() As String Dim rowNo As Integer Dim fileName As String filepath = "D:/user" Set FsysObj = CreateObject("Scripting.FileSystemObject") Set objFolder = FsysObj.GetFolder(filepath) 'clear the sheets Sheet1.Rows("1:" & Rows.Count).Delete Sheet1.Cells(1, 1).Value = "Lastname" Sheet1.Cells(1, 2).Value = "Firstname" Sheet1.Cells(1, 3).Value = "ID" rowNo = 2 For Each file In objFolder.Files FirstName = Null LastName = Null ids = Null 'get Base name of a file without extension fileName = CreateObject("Scripting.FileSystemObject").GetBaseName(file.Name) SplitArray = Split(fileName, ", ") LastName = SplitArray(0) 'Split with space to getting id and first name If UBound(SplitArray) = 1 Then ID = Split(SplitArray(1), " ") Else LastName = Null End If If (UBound(ID) = 1) Then FirstName = ID(0) ids = ID(1) End If 'All values are found then stored it into excel sheet If Not (IsNull(FirstName) Or IsNull(LastName) Or IsNull(ids)) Then Sheet1.Cells(rowNo, 1).Value = LastName Sheet1.Cells(rowNo, 2).Value = FirstName Sheet1.Cells(rowNo, 3).Value = ids rowNo = rowNo + 1 End If Next file End Sub