Guarda copia de libro origen consecutivos
Como te trata la vida amigo
Eta macro me guarda una copia del libro origen, con el nombre que quiero, TODO PERFECTO. Guarda en la ruta del oorigen la copia, Ej.: = Nombre1 Nombre2 Prueba 16-08-15.xls el 2º copia como: Nombre1 Nombre2 Prueba 16-08-15_2.xls, la 3ª copia como: Nombre1 Nombre2 Prueba 16-08-15_3.xls, bien pero sopone tu que existen los archivos (copias) con el consecutivo no seguidos si no que
Nombre1 Nombre2 Prueba 16-08-15.xls
Nombre1 Nombre2 Prueba 16-08-15_3.xls
Nombre1 Nombre2 Prueba 16-08-15_6.xls
Al hacer nueva copia te da el; Nombre1 Nombre2 Prueba 16-08-15_4.xls y no el _7 como debería ser que es el que sigue después del _6
¿Qué pretendo; que si existen los .xls, _3.xls, _6.xls, etc
Que crie las copias después del ultimo consecutivo existente en la ruta.
Si existen los .xls, _3.xls, _5.xls, etc. Que el consecutivo sea a partir del ultimo que exista en la ruta
Sub Guarda_consecutivo()
With ThisWorkbook.Sheets(2)
.Range("b2").Value = .Range("b2").Value
archivo = ThisWorkbook.Path & "\" & .Range("C2").Value & " " & .Range("B6").Value & " " & .Range("B10").Value & Format(Date, " dd-mm-yy")
End With
If Dir(archivo & ".xls") <> "" Then
Names.Add "archivos", "=files(""" & archivo & "*.xls"")"
archivo = archivo & Format([counta(archivos)] + 1, "_0")
Names("archivos").Delete
End If
ActiveWorkbook. SaveCopyAs archivo & ".xls" 'Guarda copia y la cierra dejendo el origen abierto COMO DEBE SER
'ActiveWorkbook. SaveAs archivo & ".xls" 'Guarda copia y cierra origen dejando abierto la copia
End SubTe dejo la macro que trabaja a perfeccion solo quiero agregarle el detalle mencionado y, si prefieres que te envíe el libro, lo hare
1 Respuesta
H o l a:
Te anexo la macro con los cambios.
Sub Guarda_consecutivo()
'Act.Por.Dante Amor
With ThisWorkbook.Sheets(2)
.Range("b2").Value = .Range("b2").Value
archivo = .Range("C2") & " " & .Range("B6") & " " & .Range("B10") & Format(Date, " dd-mm-yy")
End With
'
ruta = ThisWorkbook.Path & "\"
wmax = 0
exis = False
arch = Dir(ruta & archivo & "*.xls*")
'
Do While arch <> ""
nom = Left(arch, InStrRev(arch, ".") - 1)
num = Val(Mid(nom, InStrRev(arch, "_") + 1))
If num > wmax Then wmax = num
arch = Dir()
exis = True
Loop
If exis Then
wmax = wmax + 1
ActiveWorkbook.SaveCopyAs archivo & "_" & wmax & ".xls"
Else
ActiveWorkbook.SaveCopyAs archivo & "_1.xls"
End If
End SubPara que todos los nombres sean coherentes y homologados, tu primer archivo no será así:
Nombre1 Nombre2 Prueba 16-08-15.xls
Será así:
Nombre1 Nombre2 Prueba 16-08-15_1.xls
El que sigue:
Nombre1 Nombre2 Prueba 16-08-15_2.xls
S a l u d o s
