Para DAM instruccion en VB que al cerrar un archivo lo guarde como ORIGINAL en el lugar donde lo abrio y una copia en otro lugar
Hola DAM
Actualmente tengo este macro
Private Sub Workbook_BeforeClose(Cancel As Boolean)
GuardaCopia
End Sub
______________________________________________________________
Sub GuardaCopia() 'Excel superior a 2003.
Dim ruta$, nombre$, nombreC$, punto&, resp&
On Error GoTo Errores 'Control de errores.
nombre = ActiveWorkbook.Name 'Nombre del archivo actual.
punto = InStr(nombre, ".") 'Posición del punto.
If punto = 0 Then ActiveWorkbook.Save 'Si no tiene extensión (no se ha guardado), _
muestro el cuadro de diálogo GUARDAR COMO.
resp = 6 'Valor por defecto para guardar la copia.
ruta = ActiveWorkbook.Path 'Ruta del libro actual.
nombre = "\" & ActiveWorkbook.Name 'Nombre del libro actual.
punto = InStr(nombre, ".") 'Posición del punto.
If Mid(nombre, punto) = ".xlsx" Then 'Si el libro no está habilitado para macros...
resp = MsgBox("Para guardar Copia con nombre+Fecha es preciso " & vbCr & _
"habilitar el libro para macros." & vbCr & vbCr & _
"SI = Habilitar para macros." & vbCr & "NO = No guardar copia.", _
vbYesNo, "AnSanVal") 'Mensaje informativo.
If resp = vbYes Then nombre = Left(nombre, punto) & "xlsm" 'Extensión de libro _
habilitado para macros.
End If 'Mid(nombre...
nombreC = "\MisCopias" & Left(nombre, punto - 1) & Replace(Format(Now, " ddmmm hh:mm"), _
":", "·") & ".xlsm" 'Nombre para la copia.
If Dir(ruta & "\MisCopias\", vbDirectory) = "" Then MkDir ruta & "\MisCopias\" 'Si _
no existe la carpeta "MisCopias"; la crea.
If resp = vbYes Then Guardar ruta & nombreC 'Guardo con nombre + fecha.
Guardar ruta & nombre 'Guardo con nombre "simple".
CuentaCopias ruta & "\MisCopias\", Mid(Left(nombre, punto - 1), 2) ' _
Si existen más de 3 copias borro la más antigua.
ActiveWorkbook.SaveCopyAs "C:\TempLenovo\MrClAcKlEOriginal.xlsm"
Exit Sub 'Fin del proceso.
Errores: 'Control de errores.
If Err.Number = 4198 Then Exit Sub 'Guardado cancelado.
MsgBox "Error: " & Err.Number & " " & Err.Description 'Error no controlado.
End Sub 'GuardaCopia
Sub Guardar(nombre$)
Application.DisplayAlerts = False 'Desactivo "Mostrar mensajes".
ActiveWorkbook.SaveAs Filename:=nombre, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 'Guardo libro o copia+fecha.
Application.DisplayAlerts = True 'Activo "Mostrar mensajes".
End Sub 'Guardar
Sub CuentaCopias(ruta$, nombre$)
Dim archivo$, num&, archViejo$, miFecha As Date
archivo = Dir(ruta & nombre & "*") 'Busco la primera coincidencia.
miFecha = Now 'Fecha y hora actual.
Do While archivo <> ""
If FileDateTime(ruta & archivo) < miFecha Then 'Si fecha de archivo es menor...
miFecha = FileDateTime(ruta & archivo) 'Fecha del archivo leido.
archViejo = ruta & archivo 'Ruta y nombre del archivo leido.
End If 'If FileDateTime...
num = num + 1 'Incremento el contador.
archivo = Dir() 'Busco coincidencia siguiente.
Loop
If num > 3 Then Kill (archViejo) 'Borro el más antiguo?
End Sub 'CuentaCopiasEsto lo que me hace, palabras mas palabras menos es que cuando yo le doy guardar, o cierro el excel por equivocacion antes de guardar, de todos modos él me lo guarda, por un lado como original con el nombre "CONSULTORIO" y ademas en una carpeta en C:\TempLenovo\ tambien me lo guarda pero con otro nombre y me va guardando. Eso lo hice así por si por cosas de la vida alguien de MALDAD me borrara el archivo original, aun tendría una copia de respaldo OCULTA.
Hasta ahí todo muy bien y me ha funcionado, pero quisiera una tercera COPIA pero me gustaría de la siguiente manera si es posible, que esa tercera copia se llamara "CONSULTORIO Yeimy.xlsm" y que la guardara en la carpeta F:\Miguel\Dropbox\ pero quiero que esa copia NO TENGA las hojas llamadas "UltimaVisita" "ESTADISTICAS" "CIERRE" "VISITAS" "COPIARDATOS" "CLIENTE" "FORMULARIO" pues es información confidencial que solo quiero tenerlo en el archivo ORIGINAL.
¿Me ayudas con esa macro?
