Guarda rango en libro aparte pero con fecha descuadrada

Dan tengo un codigo que me proporcionaste el cual funciona de maravilla que es este:

Sub GuardarRANGO()
'Por.Dante Amor
'guarda el libro y toma los datos de input
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
Set r = h1.Range("A2:CE790")
'
ruta = l1.Path & "\"
libro = InputBox("Nombre del Archivo", "LIBRO ANALISIS")
hoja = InputBox("Nombre de la hoja", "HOJA")
If libro = "" Then Exit Sub
If hoja = "" Then Exit Sub
'
Set l2 = Workbooks.Add
Set h2 = l2.Sheets(1)
'
r.Copy h2.[A1]
h2.Name = hoja
l2.SaveAs Filename:=ruta & libro & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
l2.Close
MsgBox "rango copiado", , "AVISO"
Application.DisplayAlerts = False
ENTREHOJA.Show
End Sub

el cual esta en esta hoja

Si puedes ver, en la celda B2 esta una fecha que pongo por medio de la formula (='TOTAL ENTR.'! D3) es una fecha que introduzco en la hoja TOTAL ENTR. Y ahi jala hacia la hoja que te enseño, y aun lado esta la formula =ahora() en letras pequeñas color negro. EL PUNTO ESTA cuando ejecuto el codigo de arriba (FUNCIONA)

Pero sale asi:

Las fechas salen con dia anterior de hace 3 años ¡¿?! AL IGUAL que la formula de ahora sale con un dia de atraso de hace 3 años

¿Dónde puede estar el error? EN LA HOJA tengo este codigo


1 respuesta

Respuesta
1

Cambia esta línea:

r.Copy h2.[A1]

Por estas:

    r.Copy
    h2.[A1].PasteSpecial Paste:=xlPasteValues
    h2.[A1].PasteSpecial Paste:=xlPasteFormats

sal u dos

NO me funciono :c, ¿en el evento de la hoja tengo esto crees que este afectando?

Private Sub Worksheet_Activate()
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
ActiveSheet.ScrollArea = "B1:CN820"
ActiveSheet.Range("D6:E790").NumberFormat = "GENERAL"
ActiveSheet.Range("G6:H790").NumberFormat = "GENERAL"
ActiveSheet.Range("J6:M790").NumberFormat = "GENERAL"
ActiveSheet.Range("O6:BN790").NumberFormat = "GENERAL"
Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",FALSE)"
ActiveSheet.Protect ''AQUI CONTRASEÑA
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False
If Not Intersect(Target, Range("D6:BN790")) Is Nothing Then
For Each D In Target
If D.Value <> "" Then
If Not IsNumeric(D.Value) Then
Application.EnableEvents = False
D.Value = ""
D.Select
celda = celda & D.Address & " "
datoerrD = True
Application.EnableEvents = True
End If
End If
Next
If datoerrD Then
MsgBox "Intentaron poner letras en las celdas " & celda, vbexclamantion, "NO PERMITIDO"
End If
End If


'************************
Application.ScreenUpdating = False
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
'Act.Por.Dante Amor
If Not Application.Intersect(Target, Range("j6:j790")) Is Nothing Then
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
If Range("J1") = "" Then
MsgBox " Se te olvida la Hora base de: " & Range("j2"), vbOKOnly + vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Else
If Cells(Target.Row, "E") = "" Then
MsgBox " Se te olvida el pedido : " & Cells(Target.Row, "B").Value, vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Exit Sub
End If
Range("BR" & Target.Row) = Date
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
Range("BQ" & Target.Row) = Range("j1")
End If
End If
'***************************
Application.ScreenUpdating = False
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
'Act.Por.Dante Amor
If Not Application.Intersect(Target, Range("K6:K790")) Is Nothing Then
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
If Range("K1") = "" Then
MsgBox " Se te olvida la Hora base de: " & Range("K2"), vbOKOnly + vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Else
If Cells(Target.Row, "E") = "" Then
MsgBox " Se te olvida el pedido : " & Cells(Target.Row, "B").Value, vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Exit Sub
End If
Range("BV" & Target.Row) = Date
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
Range("BU" & Target.Row) = Range("K1")
End If
End If


'***************************
Application.ScreenUpdating = False
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
'Act.Por.Dante Amor
If Not Application.Intersect(Target, Range("L6:L790")) Is Nothing Then
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
If Range("L1") = "" Then
MsgBox " Se te olvida la Hora base de: " & Range("L2"), vbOKOnly + vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Else
If Cells(Target.Row, "E") = "" Then
MsgBox " Se te olvida el pedido : " & Cells(Target.Row, "B").Value, vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Exit Sub
End If
Range("BZ" & Target.Row) = Date
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
Range("BY" & Target.Row) = Range("L1")
End If
End If
'***************************
Application.ScreenUpdating = False
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
'Act.Por.Dante Amor
If Not Application.Intersect(Target, Range("M6:M790")) Is Nothing Then
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
If Range("M1") = "" Then
MsgBox " Se te olvida la Hora base de: " & Range("M2"), vbOKOnly + vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Else
If Cells(Target.Row, "E") = "" Then
MsgBox " Se te olvida el pedido : " & Cells(Target.Row, "B").Value, vbExclamation, "ALTO"
Application.EnableEvents = False
Target.Select
Target = ""
Application.EnableEvents = True
Exit Sub
End If
Range("CD" & Target.Row) = Date
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
Range("CC" & Target.Row) = Range("M1")
End If
End If
ActiveSheet.Unprotect ''AQUI CONTRASEÑA
ActiveSheet.Range("D6:E790").NumberFormat = "GENERAL"
ActiveSheet.Range("G6:H790").NumberFormat = "GENERAL"
ActiveSheet.Range("J6:M790").NumberFormat = "GENERAL"
ActiveSheet.Range("O6:BN790").NumberFormat = "GENERAL"
ActiveSheet.Range("j1:m1").NumberFormat = "h:mm AM/PM"
ActiveSheet.Protect ''AQUI CONTRASEÑA
End Sub

Me sigue saliendo la hoja con fecha atrasada y con 3 años atrás

Quita todas las macros de los eventos de la hoja.

Prueba nuevamente la macro que te envié para copiar el rango.

Sal u dos

BORRE las macros de la hoja y no me funciono

Quite la fórmula de la fecha y la puse manual y tampoco funciono

No me funciona :C

Envíame tu archivo, recuerda poner tu usuario en el asunto

Ya te lo envíe

No llegó.

Mi correo [email protected]

Pon todas las macros tal cual las tienes con el problema.

Quitaste esta línea

r.Copy h2.[A1]

y pusiste las que te dije?????

SI SI lo hice lo quite y puse el que me pusiste

Sigue sin llegar el correo

Puedes enviarlo otra vez

Mi correo [email protected]

YA lo intente de nuevo

H  o l a :

Tienes problemas en tus hojas, están dañadas. Tienes que pasar hoja por hoja a un nuevo libro.

Cuando pases la información a un nuevo libro, procura copiar solamente el rango de datos que estás ocupando, ya que si copias miles de celdas vacías el archivo empezará a crecer de tamaño y es probable que se vuelva a dañar.

Por ejemplo, me enviaste un archivo con 3 hojas y medía 3.5 megas. Te estoy regresando el archivo con las mismas 3 hojas y mide 922k.

Tienes muchas fórmulas vacías, no deberías tener tantas fórmulas sin ocupar, copia las fórmulas cuando ya las vayas a ocupar, esto también hace que incremente de tamaño el archivo.

sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas