Códigos que copian dos veces la misma información.
Hace tiempo en este mismo foro me ayudaron con unos códigos para copiar una información de un libro a otro libro y que al final cree dos copias de solo lectura. Eso lo hace muy bien, al inicio de la macro pongo lo siguiente:
Private Sub Workbook_Open() Call Grabar_xlsm Call Copiar_adjuntos Ahoja = "INDICE" Sheets(Ahoja).Select ActiveWorkbook.Close xlNo End Sub
Cuando esta en ese orden la nueva información no es guardada, pero en el siguiente orden la misma información se copia dos veces:
Private Sub Workbook_Open() Call Copiar_adjuntos Call Grabar_xlsm Ahoja = "INDICE" Sheets(Ahoja).Select ActiveWorkbook.Close xlNo End Sub
Por favor podrían ayudarme como puedo corregir este inconveniente, envió el código:
'Copiar informacion de Reporte a Bitacora
Sub Copiar_adjuntos()
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Ruta = "C:\Users\z003bpca\Desktop\Bitacora\"
arch = "copy_Reporte.xls"
If Dir(Ruta & arch) = "" Then
MsgBox "El archivo Reporte no existe en la ruta", vbCritical
Exit Sub
End If
'
Set l2 = Workbooks.Open(Ruta & arch)
Set h2 = l2.Sheets("Sheet0")
Num = h2.Range("D5").Text
If Num = "" Then
MsgBox "La celda D5 no contiene datos", vbExclamation
l2.Close False
Exit Sub
End If
If IsNumeric(Num) Then
Num = "" & Val(Num)
End If
'
existe = False
For Each h In l1.Sheets
If h.Name = Num Then
existe = True
Set h1 = h
Exit For
End If
Next
'
If existe = False Then
l1.Sheets.Add after:=l1.Sheets(l1.Sheets.Count)
Set h1 = l1.ActiveSheet
'copia de columna A de Hoja Datos
Sheets("Datos").Visible = True
Sheets("Datos").Columns("A").Copy h1.Columns("A")
'Sheets("Datos").Visible = False
h1.Name = Num
End If
'
'uc = h1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
'If uc < Columns("B").Column Then uc = Columns("B").Column
'h2.Range("O42:O104").Copy h1.Cells(1, uc)
h1.Columns("B").Insert
H2. Range("O42:O53"). Copy h1.Cells(8, "B")
H2. Range("O63:O68"). Copy h1. Cells(20, "B")
h2.Range("O79:O104").Copy h1.Cells(25, "B")
'ajusta columnas de B en adelante a 30
h1.Columns.ColumnWidth = 30
h1.Columns("A:A").EntireColumn.AutoFit
l2.Close False
l1.Save
Application.ScreenUpdating = True
'MsgBox "Copia realizada", vbInformation
End Sub
Respuesta de Oscar Robalino
1
EL otro código
Sub Grabar_xlsm()
DirCopia = "C:\syncplicity\z003bpca\Documents\Bitacora\Bitacora\" 'carpeta donde grabar la copia sin macros y de solo lectura.
'control de existencia de carpeta
On Error Resume Next
ChDir DirCopia
If Err = 76 Then
QueHago = MsgBox("la carpeta " & DirCopia & " NO existe." & Chr(10) & "¿La creo?", vbOKCancel, "NO ESTA ¿QUE HAGO?")
If QueHago = 1 Then
MkDir DirCopia
Else
Exit Sub
End If
End If
Err.Clear
On Error GoTo 0
DirCopia = DirCopia & IIf(Right(DirCopia, 1) = "\", "", "\")
NomArch = ActiveWorkbook.Name
Carpeta = ActiveWorkbook.Path
NomArchi = "Bitacora CT Telefono"
NomArchi1 = "Bitacora CT PC"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.SaveAs DirCopia & NomArchi1 & ".xlsm", xlOpenXMLWorkbookMacroEnabled, , xlYes
ActiveWorkbook.SaveAs DirCopia & NomArchi & ".xlsx", xlOpenXMLWorkbook, , xlYes
If Err.Number <> 0 Then
Else
Workbooks.Open Carpeta & "\" & NomArch
'Application.ScreenUpdating = True
'Application.ScreenUpdating = False
Windows(NomArchi & ".xlsx").Activate
ElMensaje = "Este archivo y las copias de seguridad " & Chr(10) & NomArchi & ".xlsm/.xlsx" & " en " & DirCopia & Chr(10) & "acaban de grabarse."
TipoMens = vbInformation
ElTitulo = "ARCHIVOS GRABADOS"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Subes el siguiente:
