Crear carpetas y sub carpetas con macros

Acudiendo nuevamente a los expertos.

Esta macro lo encontré de la srta. Experta Elsamatilde y esta excelente como siempre, pero quiero por favor para que lo ajusten a mis necesidades, resulta que la macro te crea 1 carpeta y 1 subcarpeta y yo quiero que me cree más subcarpetas.

Sub creaCarpeta()
'x Elsamatilde

Dim rutaBase As String, carpeta As String
'variables para ajustar
rutaBase = "C:\"
carpeta = Sheets("Resumen").Range("C2") & "\"

'controla posible error de que ya exista la carpeta
On Error Resume Next
MkDir rutaBase & carpeta
ActiveWorkbook.SaveCopyAs rutaBase & carpeta & ActiveWorkbook.Name
End Sub

Ejemplo.

La macro: " C:\Carpeta 1\Carpeta 2 " y allí queda, es todo lo que hace o crea

Lo que deseo que lo ajusten a: C:\Carpeta 1\Carpeta 2\Carpeta 3\Carpeta 4 " que se pueda crear mas subcarpetas y eso que en "carpeta = Sheets("Resumen").Range("C2") & "\"  = esta escrito " Carpeta 1\Carpeta 2\Carpeta 3\Carpeta 4 ", pero no lo crea las demas subcarpetas, la macro solo llega asta la "Carpeta 2".