Macro Excel para copia de rango con error
Esta la macro del amigo Dante con mucha modificación para esta plantilla
Sub guardar_Copia() 'GUARDAR la hoja como XLSX, y PDF, sin butones, imagenes y macros
'Por.Dante Amor http://www.todoexpertos.com/preguntas/6fxnalqm9tyxkxdd/en-macro-excel-copiar-el-rango-en-ves-de-la-hoja?selectedanswerid=6g395i5pqbj6ipxt
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'& Format(.Range("H3"), "2016-00000") '"0000")
Set h1 = Sheets(1)
'Nombre para el archivo Para solo las iniciales en E8
nbr = Ini(Quitar(h1.Range("E4"))) & "_" & h1.Name & " " & Format(h1.Range("H3"), "2016-00000") & " " & h1.Range("E8").Value
'Ruta carpeta destino en la ventana Guardar como:. Puede cambiar la ruta aqui
rut = "C:\0\"
'El cuadro dialogo abre en la carpeta de rut Guardar copia desde el cuadro dialogo
With Application.FileDialog(msoFileDialogFolderPicker) 'Abre el cuadro dialogo
.Title = "Selecciona destino"
.AllowMultiSelect = False
.InitialFileName = rut
'Si cancela sale de la macro
If .Show <> -1 Then Exit Sub
cp = .SelectedItems(1)
End With
'Copia la hoja
h1.Copy
'Elimina objetos Shapes (formas) existentes en la hoja
Set h2 = Sheets(1)
h2.Unprotect Password:="By Jot@" 'Desprotege la copia .Ver si funciona bien sin o con el passw
'Establecer área de impresión
h2.PageSetup.PrintArea = "$B$2:$H$40"
'elimina controles
''''h2.DrawingObjects.Delete 'elimina todo objecto que exista en la hoja; botones imagenes etc
'elimina los objectos; imagenes, botónes etc., SOLO los que menciona en el Array
h2.Shapes.Range(Array("SpinB1", "B_1")).Delete
'Por si hay datos en este rango y no los quiere en la copia, los eliminará pero tendras Desproteger este rango en la hoja Copia
h2.Unprotect Password:="By Jot@" 'Desprotege la copia para ejecutar limpiesa en el rango
h2.Range("I1:AZ1500").Clear 'puede cambiar el rango o desactivarlo si no lo necesita
'Proteger la copia completa totalmente
h2.Protect Password:="By Jot@", DrawingObjects:=True, Contents:=True, Scenarios:=True
h2.EnableSelection = xlNoSelection 'Restringe todo, seleccion y escritura
ActiveWorkbook.Protect Password:="By Jot@", Structure:=True, Windows:=True
'Guarda hoja en PDF
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=cp & "\" & nbr & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'Guarda hoja como xlsx
ActiveWorkbook.SaveAs Filename:=cp & "\" & nbr & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close
MsgBox "Archivos guardados en " & cp & " como:" & vbCr & nbr & ".xlsx" & " y " & ".PDF", vbInformation, "Guardado"
[A1].Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
