Macro vba donde crea carpeta y sub-carpeta basado en celdas y en las subcarpetas crea archivos de excel también basados en celda

El tema es el siguiente tengo una hoja de excel donde cree una macro que me creaba una carpeta con el nombre de cliente que designaba en una celda y posteriormente dentro de esta carpeta creaba archivos de Excel o Word que con nombres ya registrados en la misma hoja.

Pero ahora se me ha presentado que debo clasificar los datos, entonces, a parte de crear la carpeta CLIENTE, ahora debo crear una SUB-CARPETA con el nombre de cada proceso, este nombre sale listado en celdas y al lado de cada una de ellas, esta el archivo que debe crear dentro de cada una de ellas y también registrados en celdas.

Coloco un ejemplo como ilustración:

        A                  B                        C

1  Cliente     Proceso 1     Archivo 1.xls
2                    Proceso 1     Archivo 2.xls

3                    Proceso 2     Archivo 3.xls
4                    Proceso 3    Archivo 4.xls

5                    Proceso 3    Archivo 5.xls

Y así sucesivamente, manejando el archivo por independiente puedo crear los archivos y el nombre de la carpeta cliente, pero he intentado adicionar que me cree la sub-carpeta para que me cree los archivos que corresponda según cada proceso en su carpeta y no le he encontrado la vuelta.

Anexo el código a ver que estoy haciendo mal o que no estoy tomando en consideración:

Option Explicit
Sub Crear_Click()
Application.ScreenUpdating = False
'Declaración variables de aplicaciones
Dim wordapp As Word.Application
Dim Excelapp As Excel.Application
'Declaración de Variables para creación de Documentos
Dim fs As FileSystemObject
Dim Documentow As Document
Dim Documentox As Workbook
'Declaración de Variables para dirección, extensión y clave de los documentos
Dim Dirección, Extensión, Clave, Cliente, Sub_Carpeta As String
Dim Files, Files2, i, j As Integer
'Seteando Aplicación para que recree un archivo cada vez que se lea un archivo
Set wordapp = New Word.Application
Set Excelapp = New Excel.Application
Set fs = New FileSystemObject
'Ubica el cursor donde se encuentran los nombres de los archivos a crear según selección
Range("A2").Select
Sub_Carpeta = Cells(Rows.Count, 1).End(xlUp).Row

Range("B2").Select
Files = Cells(Rows.Count, 1).End(xlUp).Row

'Inicializando el ciclo de lectura de las celdas
For j = 2 To Sub_Carpeta

'Asignando valores a las variables
Extensión = Range("Q1").Value
Clave = Range("S1").Value
Cliente = Range("D2").Value
Dim Inicial_Sub_Carpeta As String
Dim Nombre_Sub_Carpeta As String
Inicial_Sub_Carpeta = ThisWorkbook.Worksheets(1).Cells(j, 1).Value
'Validando si hay lineas en blanco.
If Inicial_Sub_Carpeta = "" Then
Else
Nombre_Sub_Carpeta = ThisWorkbook.Worksheets(1).Cells(j, 1).Value
Dirección = Trim(ThisWorkbook.Path & "\" & Cliente & "\" & Nombre_Sub_Carpeta)
If fs.FolderExists(Direccion) = False Then
MsgBox (fs.FolderExists(Direccion))
Else
fs.CreateFolder (Direccion)
End If

For i = 2 To Files
'Inicializando variables del Ciclo
Dim Inicial_Archivos As String
Dim Nombre_Archivos As String

'Asignando valores según la posición que se encuentre la información en la hoja
Inicial_Archivos = ThisWorkbook.Worksheets(1).Cells(i, 2).Value
'Validando si hay lineas en blanco.
If Inicial_Archivos = "" Then
Else
Nombre_Archivos = ThisWorkbook.Worksheets(1).Cells(i, 2).Value

Select Case Extensión

Case Extension To "xlsm"

If Clave = Empty Then
Set Documentox = Excelapp.Workbooks.Add
Documentox.SaveAs Filename:=Dirección & "\" & Nombre_Archivos, _
FileFormat:=52, Password:=""
Documentox.Close savechanges:=True
Else
Set Documentox = Excelapp.Workbooks.Add
Documentox.SaveAs Filename:=Dirección & "\" & Nombre_Archivos, _
FileFormat:=52, Password:=Clave
Documentox.Close savechanges:=True
End If

End Select

End If
'Finalizamos o inicializamos el ciclo nuevamente hasta validar todas las lineas
Next i
End If
Next j

wordapp.Application.Quit
Excelapp.Application.Quit

'Borramos las variables para que inicialicen en blanco.
Set fs = Nothing
'Set objselection = Nothing
Set Documentow = Nothing
Set Documentox = Nothing
Set wordapp = Nothing
Set Excelapp = Nothing
Range("A1").Select

Application.ScreenUpdating = True
End Sub

Te agradezco mucho el apoyo de antemano a ver si puedes ver porque no funciona, se que tiene que ver algo en la forma como corre en bucle, pero no se que parte.