Macro para unificar 3 hojas de un libro de excel en un nuevo archivo de excel y otro con PDF con un botón
Quiero pedir apoyo con una macro, tengo una macro (alguien muy bondadoso me apoyo) que a través de un botón unifica 3 hojas en un nuevo archivo de excel, el detalle de estas hojas que las tengo con mas macros y botones que me ocultar y muestran filas y cuando genero la macro para crear el nuevo archivo, solo en una hoja es donde la crea tal y como esta en las otras 2 no las crea tal y como están en el archivo no realiza la función de ocultar filas, y también quisiera que esas 3 hojas la creara con otro botón en un solo archivo pero en formato pdf.
Y en el caso del Excel solo en una hoja me funcionan los subtotales en las otras dos hojas no funciona, alguien podría apoyarme
Adjunto el código
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 Subde la macro de excel para crear el nuevo archivo
1 respuesta
Respuesta de Dante Amor
2
Prueba este código
Sub Crear_xls_1()
Dim wb2 As Workbook
Dim sh2 As Worksheet
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
'
Sheets.Copy
Set wb2 = ActiveWorkbook
For Each sh2 In wb2.Sheets
Select Case sh2.Name
Case "Análisis de Créditos"
Call valores(sh2, "B7:K")
Case "Análisis de Débitos"
Call valores(sh2, "A7:G")
Case "Junta Directiva (Imprimir)"
Call valores(sh2, "A4:D")
End Select
Next
'
For Each sh2 In wb2.Sheets
Select Case sh2.Name
Case "Análisis de Créditos"
Call eliminar(sh2, "L1:Z", "J")
Case "Análisis de Débitos"
Call eliminar(sh2, "H1:Z", "F")
Case "Junta Directiva (Imprimir)"
Call eliminar(sh2, "E1:Z", "D")
Case Else
sh2.Delete
End Select
Next
'
wb2.SaveAs ThisWorkbook.Path & "\" & "3 hojas" & ".xlsx", xlOpenXMLWorkbook
wb2.Close False
Application.CopyObjectsWithCells = True
MsgBox "Hojas. Guardadas en un nuevo archivo"
End Sub
'
Sub eliminar(sh2 As Worksheet, rango As String, col As String)
Dim i As Long
sh2.Range(rango & sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row).EntireColumn.Delete
For i = sh2.Range(col & Rows.Count).End(3).Row To 8 Step -1
If sh2.Rows(i).Hidden = True Then sh2.Rows(i).Delete
Next
End Sub
'
Sub valores(sh2 As Worksheet, rango As String)
sh2.Unprotect "regional2018"
With sh2.Range("B7:K" & sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row)
.Value = .Value
End With
End Sub
Para enviar también a PDF
Sub Crear_xls_1()
Dim wb2 As Workbook
Dim sh2 As Worksheet
Dim Nombre As String
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
'
Sheets.Copy
Set wb2 = ActiveWorkbook
For Each sh2 In wb2.Sheets
Select Case sh2.Name
Case "Análisis de Créditos"
Call valores(sh2, "B7:K")
Case "Análisis de Débitos"
Call valores(sh2, "A7:G")
Case "Junta Directiva (Imprimir)"
Call valores(sh2, "A4:D")
End Select
Next
'
For Each sh2 In wb2.Sheets
Select Case sh2.Name
Case "Análisis de Créditos"
Call eliminar(sh2, "L1:Z", "J")
Case "Análisis de Débitos"
Call eliminar(sh2, "H1:Z", "F")
Case "Junta Directiva (Imprimir)"
Call eliminar(sh2, "E1:Z", "D")
Case Else
sh2.Delete
End Select
Next
'
Nombre = ThisWorkbook.Path & "\" & "3 hojas"
wb2.SaveAs Nombre & ".xlsx", xlOpenXMLWorkbook
wb2.ExportAsFixedFormat xlTypePDF, Nombre & ".pdf"
wb2.Close False
Application.CopyObjectsWithCells = True
MsgBox "Hojas. Guardadas en un nuevo archivo"
End Sub
'
Sub eliminar(sh2 As Worksheet, rango As String, col As String)
Dim i As Long
sh2.Range(rango & sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row).EntireColumn.Delete
For i = sh2.Range(col & Rows.Count).End(3).Row To 8 Step -1
If sh2.Rows(i).Hidden = True Then sh2.Rows(i).Delete
Next
End Sub
'
Sub valores(sh2 As Worksheet, rango As String)
sh2.Unprotect "regional2018"
With sh2.Range("B7:K" & sh2.UsedRange.Rows(sh2.UsedRange.Rows.Count).Row)
.Value = .Value
End With
End Sub
