solucionado Macro para guardar hoja en otro libro

SALAVERRINO · el 8 de junio

Buenos días a los integrantes de este prestigioso foro, esta ocasión recurro a uds para que me ayuden con una macro o quizás mejorarla, la idea que tengo es extraer toda la información (conservando su formato) de la pestaña CONSOLIDADO y que se guarde automáticamente en la carpeta donde se está trabajando, el nombre del archivo que se extrae esta en hoja PLANILLA celda D2, fecha y hora y con la extensión “.xlsx” (CONSOLIDADO CYPRESS ARROW2 2-5-2019 18-20-56 HRS.xlsx), como se aprecia en la macro que describe a continuación.

Adjunto link de archivo.

https://drive.google.com/file/d/1_SVxDlLOyuGGmpIih5d-M4wYJSm6S7La/view?usp=sharing

Modulo 5:

Sub GuardarComo30072015()

Dim ncorr As String
With Application
.ScreenUpdating = False

NOMBRE = ThisWorkbook.Name
carpeta = ThisWorkbook.Path
filaa = carpeta & "\" & NOMBRE

ncorr = Format(Hoja1.Range("D2").Value, "000")

A = " " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & "-" & Second(Time) & " HRS"

.DisplayAlerts = False
.EnableEvents = False
If nombrar = vbYes Then
    filab = carpeta & "\" & "plantilla electronica1"
    ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled

Else
        filab = carpeta & "\" & "CONSOLIDADO " & ncorr & UCase(titulo) & A
        Call Elimina_hojas
        ActiveWorkbook.SaveAs Filename:=filab, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        ActiveWorkbook.Close
End If
.EnableEvents = True
.DisplayAlerts = True

xnombre = ActiveWorkbook.Name
Workbooks.Open filaa
vuf = Range("B" & Rows.Count).End(xlUp).Row
Range("B8:AQ" & vuf).ClearContents
Workbooks(xnombre).Close

.ScreenUpdating = True
End With

End Sub

Sub Elimina_hojas()
Dim Vec, Elim, ws As Worksheet
'
Vec = Array("PLANILLA", "RESUMEN", "BOLETA", "CONSOLIDADO", "DATA", "EXPORTA", "REPORTE BOLETAS", "TELECREDITO JUDICIAL", "TELECREDITO", "DESCUENTO", "MENU", "SORT", "NAVI", "RECIBO", "TABLA AFP") ' Estas son las hojas que se mantienen.
'
ReDim Elim(0 To 0)
For Each ws In Worksheets
  If IsError(Application.Match(ws.Name, Vec, 0)) Then
    ReDim Preserve Elim(1 To 1 + UBound(Elim)): Elim(UBound(Elim)) = ws.Name
  End If
Next

Application.DisplayAlerts = False: On Error Resume Next
  Worksheets(Elim).Delete
On Error GoTo 0: Application.DisplayAlerts = True
MsgBox "Finalizando....."
Sheets("MENU").Activate
Range("B8").Select
End Sub

Desde ya agradezco su apoyo y colaboración.

Haplox · el 11 de junio

En 8/6/2019 at 17:14 , SALAVERRINO dijo:

Desde ya agradezco su apoyo y colaboración.

O no he entendido lo que necesitas, o para lo que pides te sobra todo ese código :huh: . Lo que yo he entendido es esto:

Sub copiar_consolidado()
Dim nom$, fech$, hor$, fich$

Application.ScreenUpdating = False

nom = Sheets("PLANILLA").Cells(2, "d")
fech = Format(Date, "dd-mm-yy")
hor = Format(Time, "hh-mm-ss")

fich = ThisWorkbook.Path & "\" & nom & "_" & fech & "_" & hor & " HRS" & ".xlsx"

Sheets("CONSOLIDADO").Copy
ActiveWorkbook.SaveAs (fich)
ActiveWorkbook.Close

End Sub