Agregar corrección en Macro Excel para reconocer la ya creada ruta
Una nueva macro tuya a la cual eciste algunas correcciones.
Vengo con 2 temas pero uno a la vez. No respondas sin que veas las 2 preguntas porque las 2 tienen que ver entre si
1º quiero que; si el directorio (ruta) ya existe, que la reconozca y no me mande error en linea MkDir "C:\0\trabajo"
Sub CreaCarpetas() 'Por DAM Application.ScreenUpdating = False Application.DisplayAlerts = False MkDir "C:\0\trabajo" ' SI YA EXISTE LA RUTA, MANDA ERROR ruta1 = "C:\0\trabajo\" año = Format(Date, "YYYY") mes = Format(Date, "mmmm") On Error Resume Next MkDir ruta1 & "\" & año MkDir ruta1 & "\" & año & "\" & mes On Error GoTo 0 ruta = ruta1 & año & "\" & mes & "\" If Dir(ruta, vbDirectory) = "" Then 'Aqui validas si existe o no el directorio (Punto 1) MkDir ruta End If arch = Application.ActiveSheet.Name & ".xlsx" 'Aqui coje el Nombre de la Hoja Activa... Application.ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=ruta & arch, FileFormat:=xlOpenXMLWorkbook ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Hoja copiada" End Sub
1 Respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo la macro actualizada para revisar la existencia de todas las carpetas.
Sub CreaCarpetas() 'Por DAM Application.ScreenUpdating = False Application.DisplayAlerts = False año = Format(Date, "YYYY") mes = Format(Date, "mmmm") carp1 = "C:\0\" If Dir(carp1, vbDirectory) = "" Then MkDir carp1 End If carp2 = carp1 & "trabajo\" If Dir(carp2, vbDirectory) = "" Then MkDir carp2 End If carp3 = carp2 & año & "\" If Dir(carp3, vbDirectory) = "" Then MkDir carp3 End If carp4 = carp3 & mes & "\" If Dir(carp4, vbDirectory) = "" Then MkDir carp4 End If arch = ActiveSheet.Name & ".xlsx" 'Aqui coje el Nombre de la Hoja Activa... ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=carp4 & arch, FileFormat:=xlOpenXMLWorkbook ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Hoja copiada" End Sub
sal u dos
