Macro excel crear carpetas y subcarpetas

Estoy intentando crear un macro en VBA y tengo un cacao mental tremendo...

No se mucho de programación así que os comento lo que estoy intentando hacer:

Quiero crear un script que coja de la columna a nombres de carpetas y de la la columna B las de las subcarpetas y las cree en una dirección en concreta.

EJ:

A1                          B2

Perros                  pastor aleman

Perros                   husky

Perros                  Golden

Gatos                   Persa

Gatos                   Bengala

En este ejemplo al ejecutar el macro debería de crear las carpetas gatos y perros. Dentro de Gatos dos carpetas Persa y Bengala y dentro de Perros Pastor alemán, Husky y Golden.

Este es el código que he escrito:

Sub CREANDO()

'pido la ruta
miRuta = InputBox("INGRESAR LA RUTA")
'el nombre de carpeta se toma de A1
carpeta = Range("A1").Select

'inicio un bucle para crear las carpetas
Do While ActiveCell.Value <> ""
carpeta = ActiveCell.Value
'primero se crea la carpeta
MkDir miRuta & "\" & carpeta

'si se repite un nombre y da error que continue
On Error Resume Next
' recoge el nombre de la sub Carpeta
miSubcarp = Range("B1").Select
Do While carpeta = ActiveCell.Value
'Crea tantas subcarpetas sean necesarias
MkDir miRuta & "\" & carpeta & "\" & miSubcarp

!baja una posicion la selección de la celda
ActiveCell.Offset(1, 0).Select
Loop

ActiveCell.Offset(1, 0).Select
Loop

End Sub

Estoy atascado, si alguien me puede ayudar lo agradecería mucho.