Abrir libro de Excel copiar, pegar datos y cerrar libro, marca error 1004
Realice una macro, en la cual tengo un archivo de Excel llamado reporte en este está el código la idea es mediante la macro copiar una hoja y pasae los datos al archivo acumulado hoja concentrado, este último archivo se abre mediante la macro. Pero cada que lo ejecutó me manda el error 1004 y daña mi archivo acumulado.
Sub Copiar()
Dim rutaAnterior As String
Dim rutaNueva As String
Dim UltLinea, Ult, Linea As Integer
Dim Workbookvariable, xLibro1 As Workbook
rutaNueva = "I:\Acu\Acumulado.xlsx"
Set objExcel = New Excel.Application
Set xLibro1 = Workbooks.Open(rutaNueva, , False)
objExcel.Visible = False
Windows("Acumulado.xlsx").Activate
Sheets("Concentrado").Select
Windows("Reporte.xlsm").Activate
Sheets("Impresion").Select
Range("B1").Select
Linea = Range("A" & Rows.Count).End(xlUp).Row
Range("A4:V" & Linea).Select
Selection.Copy
Windows("Acumulado.xlsx").Activate
Sheets("Concentrado").Select
Range("B1").Select
UltLinea = Range("B" & Rows.Count).End(xlUp).Row
UltLinea = UltLinea + 1
Range("B" & UltLinea).Select
ActiveSheet.Paste
Range("A1").Select
Windows("Reporte.xlsm").Activate
Sheets("Impresion").Select
Range("G1").Select
Selection.Copy
Windows("Acumulado.xlsx").Activate
Sheets("Concentrado").Select
Range("A1").Select
UltLinea = 0
UltLinea = Range("A" & Rows.Count).End(xlUp).Row
Ult = Range("B" & Rows.Count).End(xlUp).Row
For UltLinea = UltLinea + 1 To Ult
If Cells(UltLinea, "B").Value <> "" Then
Range("A" & UltLinea).Select
ActiveSheet.Paste
End If
Next
Windows("Acumulado.xlsx").Activate
Sheets("Concentrado").Select
Range("B2").Select
Workbooks("Acumulado.xlsx").Close SaveChanges:=True
objExcel.Quit
End Sub
1 Respuesta
H o la :Probé tu macro y sí me funciona.
Tal vez tu archivo Acumulado tiene algún problema.
Lo que te recomiendo es que no abras el archivo en otra instancia:
Set objExcel = New Excel.Application
Ni tampoco que ocultes la aplicación
objExcel.Visible = False
Te anexo una nueva macro para que la pruebes, realiza lo mismo.
Sub CopiarDatos()
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Impresion")
'
ruta = "I:\Acu\Acumulado.xlsx"
ruta = "C:\trabajo\Acumulado.xlsx"
If Dir(ruta) = "" Then
MsgBox "No Existe El Archivo : " & ruta
Exit Sub
End If
Set l2 = Workbooks.Open(ruta, , False)
Set h2 = l2.Sheets("Concentrado")
'
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("B" & Rows.Count).End(xlUp).Row + 1
h1.Range("A4:V" & u1).Copy h2.Range("B" & u2)
'
For i = u2 To h2.Range("B" & Rows.Count).End(xlUp).Row
If h2.Cells(i, "B").Value <> "" Then
h2.Cells(i, "A") = h1.[G1]
End If
Next
l2.Close True
Application.ScreenUpdating = True
MsgBox "fin"
End SubPrueba y me comentas.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
