Crear carpeta con nombre de archivo en celda excel
Tengo una macro, la cual guarda un archivo en de excel en PDF rapidamente. Pasa que necesito mejorar esta macro para que además cree una carpeta y guarde cada archivo generado en PDF en una carpeta separada y que el nombre de estar carpeta sea sacado de una celda del mismo archivo excel.
Macro que actualmente uso:
Sub Save_as_PDF()
Application.ScreenUpdating = False
Dim number_of_files As Integer
number_of_files = ActiveSheet.HPageBreaks.Count
filename0 = ThisWorkbook.Path & "\"
For x = 1 To number_of_files
row_pagebreak = ActiveSheet.HPageBreaks(x).Location.Row
filename1 = ActiveSheet.Cells(row_pagebreak - 1, 1).Value
full_filename = filename0 & filename1
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
full_filename, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
From:=x, To:=x, OpenAfterPublish:=False
Next
End Sub
1 respuesta
Te anexo la macro para tomar el nombre de la carpeta de la misma fila que toma el nombre del archivo, pero de la columna "B".
Si la carpeta no existe, te crea la carpeta; y en esa carpeta te guarda el archivo.
Sub Save_as_PDF() Application.ScreenUpdating = False Dim number_of_files As Integer ActiveWindow.View = xlPageBreakPreview number_of_files = ActiveSheet.HPageBreaks.Count filename0 = ThisWorkbook.Path & "\" For x = 1 To number_of_files row_pagebreak = ActiveSheet.HPageBreaks(x).Location.Row carpeta = ActiveSheet.Cells(row_pagebreak - 1, "B").Value If Right(carpeta, 1) <> "\" Then carpeta = carpeta & "\" filename1 = ActiveSheet.Cells(row_pagebreak - 1, "A").Value If Dir(filename0 & carpeta, vbDirectory) = "" Then MkDir filename0 & carpeta End If full_filename = filename0 & carpeta & filename1 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=full_filename, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, From:=x, To:=x, OpenAfterPublish:=False Next ActiveWindow.View = xlNormalView MsgBox "Fin" End Sub
.
.
Revisé que la macro no genera el archivo de la última hoja, le hice unos ajustes para generar el pdf de la última hoja.
Prueba con la siguiente:
Sub Save_as_PDF2()
'Act Por Dante Amor
'
Dim number_of_files As Integer
Application.ScreenUpdating = False
'
u = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.HPageBreaks.Add Before:=Range("A" & u + 1)
ActiveWindow.View = xlPageBreakPreview
'
number_of_files = ActiveSheet.HPageBreaks.Count
filename0 = ThisWorkbook.Path & "\"
For x = 1 To number_of_files
row_pagebreak = ActiveSheet.HPageBreaks(x).Location.Row
carpeta = ActiveSheet.Cells(row_pagebreak - 1, "B").Value
If Right(carpeta, 1) <> "\" Then carpeta = carpeta & "\"
filename1 = ActiveSheet.Cells(row_pagebreak - 1, "A").Value
If Dir(filename0 & carpeta, vbDirectory) = "" Then
MkDir filename0 & carpeta
End If
full_filename = filename0 & carpeta & filename1
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=full_filename, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, From:=x, To:=x, OpenAfterPublish:=False
Next
ActiveWindow.View = xlNormalView
ActiveSheet.HPageBreaks(number_of_files).Delete
MsgBox "Fin"
End Sub.
.
