Macro para crear un nuevo archivo de excel con un botón
Dante te adjunto nuevamente una consulta para crear una nueva macro a través de un botón.
Me has apoyado en crear la macro que genere un nuevo archivo en formato Excel a través de un botón, siendo estas 3 hojas distintas a las que se les crea nuevo archivo, ahora quisiera poder que a través de un nuevo botón genere automáticamente las 3 hojas en un nuevo archivo y si fuese posible un botón para formato Excel y otro para pdf, porque muchas veces me lo piden de las dos formas.
Te adjunto la macro que esta actualmente pero que genera hoja por archivo en excel
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
1 Respuesta
Prueba lo siguiente.
Solamente tengo un detalle con borrar los botones de la derecha.
Revisa si en tu archivo se borran. Tal vez debas cambiarlos por otro con botón con un formato más sencillo.
Sub Crear_xls()
Dim wb As Workbook
Dim h2 As Worksheet
Dim i As Long, h As Long
Dim hojas As Variant, cols1 As Variant, cols2 As Variant, cols3 As Variant
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
hojas = Array("Análisis de Créditos", "Análisis de Débitos", "Junta Directiva (Imprimir)")
cols1 = Array("J", "E", "C")
cols2 = Array("J", "E", "D")
cols3 = Array("L", "H", "E")
'
Sheets(hojas(0)).Copy
Set wb = ActiveWorkbook
For h = 1 To UBound(hojas)
ThisWorkbook.Sheets(hojas(h)).Copy after:=wb.Sheets(wb.Sheets.Count)
Next
For h = 0 To UBound(hojas)
Set h2 = wb.Sheets(hojas(h))
h2.Unprotect ("regional2018")
h2.Cells.EntireRow.Hidden = False
h2.UsedRange.Value = h2.UsedRange.Value
Next
For h = 0 To UBound(hojas)
h2.Range(cols3(h) & 1, h2.Cells(1, Columns.Count)).EntireColumn.Delete
'
For i = h2.Range(cols1(h) & Rows.Count).End(3).Row To 7 Step -1
If h2.Range(cols1(h) & i) = 0 And h2.Range(cols2(h) & i) = 0 Then
h2.Range(cols1(h) & i).EntireRow.Delete
End If
Next i
Next
wb.SaveAs ThisWorkbook.Path & "\" & "3 hojas" & ".xlsx", xlOpenXMLWorkbook
wb.Close False
'
Application.ScreenUpdating = True
MsgBox "Hojas. Guardadas en un nuevo archivo"
End Sub
