Problema con macro crear carpeta

Tengo esta macro que me crea carpetas en un directorio desde una lista:

Sub Crear_carpetas()
Application.ScreenUpdating = False
contador = 0
Set fso = CreateObject("Scripting.FileSystemObject")
ruta = ActiveWorkbook.Path
Range("A2").Select
Do While Not IsEmpty(ActiveCell)
Item = ActiveCell.Value
If Len(Item) = 1 Then
Item = "0" & Item
End If
ActiveCell.Offset(0, 1).Select
Código = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Nombre = ActiveCell.Value
Carpeta = Item & "-" & Código & "-" & Nombre
If Not fso.FolderExists(ruta & "\" & Carpeta) Then
fso.CreateFolder (ruta & "\" & Carpeta)
contador = contador + 1
End If
ActiveCell.Offset(1, -2).Select
Loop
Respuesta = MsgBox("Se han creado " & contador & " carpetas", 64, "Número de Carpetas")
Set fso = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Full1.Crear_carpetas
End Sub

Me da:

se ha producido el error "76" en tiempo de ejecución:

No se ha encontrado ruta de acceso

Al depurar sale en amarillo:
Full1.Crear_carpetas

Un saludo i gracias por atanderne

Salut