Macro para crear un nuevo archivo de un archivo existente con un botón en formato excel
Dante nuevamente pidiendo tu apoyo, hace unos días me apoyaste con un código para crear un nuevo archivo en pdf y déjame decirte que funciona excelentemente bien, eres genial, ahora quisiera ver la posibilidad de que en vez de creármelo en pdf, la macro lo genere en formato de Excel, el archivo tiene 3 hojas que hace esa función, en la cual tiene otras macros para ocultas y mostrar filas y aparte te adjunto el código que me brindaste para formato PDF,
Sub Pdf_Creditos()
'Nombre de la hoja , nombre del archivo
Call Crear_Pdf("Análisis de Créditos", "Analisis_de_Creditos", "J", "J")
End Sub
'
Sub Pdf_Debitos()
'Nombre de la hoja , nombre del archivo
Call Crear_Pdf("Análisis de Débitos", "Analisis_de_Debitos", "E", "E")
End Sub
'
Sub Pdf_Transferencia()
'Nombre de la hoja , nombre del archivo
Call Crear_Pdf("Junta Directiva (Imprimir)", "Junta Directiva (Imprimir)", "C", "D")
End Sub
'
Sub Crear_Pdf(hoja, nombre, col1, col2)
Dim i As Long
Dim h1 As Worksheet
'
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = False
Application.DisplayAlerts = False
'
Set h1 = Sheets(hoja)
h1.Unprotect ("regional2018")
h1.Cells.EntireRow.Hidden = False
For i = 7 To h1.Range(col1 & Rows.Count).End(3).Row
If h1.Range(col1 & i) = 0 And h1.Range(col2 & i) = 0 Then
h1.Range(col1 & i).EntireRow.Hidden = True
End If
Next i
h1.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & nombre & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'
Application.ScreenUpdating = True
Application.CopyObjectsWithCells = True
h1.Cells.EntireRow.Hidden = False
h1.Protect ("regional2018")
MsgBox "Hoja: " & hoja & ". Guardada en un nuevo archivo: " & nombre
End Sub
1 Respuesta
Prueba la siguiente:
Sub xls_Creditos()
'Nombre de la hoja , nombre del archivo
Call Crear_xls("Análisis de Créditos", "Analisis_de_Creditos", "J", "J", "L")
End Sub
'
Sub xls_Debitos()
'Nombre de la hoja , nombre del archivo
Call Crear_xls("Análisis de Débitos", "Analisis_de_Debitos", "E", "E", "H")
End Sub
'
Sub xls_Transferencia()
'Nombre de la hoja , nombre del archivo
Call Crear_xls("Junta Directiva (Imprimir)", "Junta Directiva (Imprimir)", "C", "D", "E")
End Sub
'
Sub Crear_xls(hoja, nombre, col1, col2, col3)
Dim h1 As Worksheet, h2 As Worksheet
Dim wb As Workbook
Dim i As Long
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set h1 = Sheets(hoja)
h1.Unprotect ("regional2018")
h1.Cells.EntireRow.Hidden = False
h1.Copy
Set wb = ActiveWorkbook
Set h2 = wb.Sheets(1)
h2.UsedRange.Value = h2.UsedRange.Value
h2.Range(col3 & 1, h2.Cells(1, Columns.Count)).EntireColumn.Delete
'
For i = h2.Range(col1 & Rows.Count).End(3).Row To 7 Step -1
If h2.Range(col1 & i) = 0 And h2.Range(col2 & i) = 0 Then
h2.Range(col1 & i).EntireRow.Delete
End If
Next i
wb.SaveAs ThisWorkbook.Path & "\" & nombre & ".xlsx", xlOpenXMLWorkbook
wb.Close False
'
Application.ScreenUpdating = True
h1.Protect ("regional2018")
MsgBox "Hoja: " & hoja & ". Guardada en un nuevo archivo: " & nombre
End Sub
¡Gracias!
Dante, eres un genio....
Me funciona excelente ya hice las pruebas y genera los nuevos archivos muy bien, se podrá hacer que con un nuevo botón genere en un nuevo archivo las 3 hojas.
Slds.
¿Pero quieres las 3 hojas en un solo archivo?
Si exacto que esas 3 hojas que se crean por separado ahora se pudieran integrar en un nuevo archivo con las 3 hojas
Es una nueva macro. Crea una nueva pregunta.
