Macro para copiar de un documento sin dejar fila en blanco.
El código que estoy usando para trasladar datos de un documento a otro, funciona muy bien la primera vez, pero me deja una (o varias) celdas en blanco en el documento destino a partir de la segunda vez que ejecuto la macro.
Adjunto un screenshot, tambien me gustaria que limpiara la hoja origen, dejandola solo con los encabezados (fila 1) y borrando todo (formato, formulas y contenido).
Gracias por su tiempo :)
Estas son las celdas vacias que me deja, las columnas A y B siempre van a tener informacion.
Sub CopiarCeldas()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
ruta = l1.Path & "\"
'
On Error Resume Next
Set l2 = Workbooks.Open(ruta & "OhnDoc.xlsm")
On Error GoTo 0
'
hojas = Array("OhnCF", "OhnSw", "OhnOp")
For i = LBound(hojas) To UBound(hojas)
existe = False
hoja = hojas(i)
For Each h In l2.Worksheets
If h.Name = hoja Then
existe = True
Exit For
End If
Next
If existe Then
Set h2 = l2.Worksheets(hoja)
u = h2.UsedRange.Rows(h2.UsedRange.Rows.Count).Row + 1
l1.Sheets(hoja).UsedRange.Copy h2.Cells(u, "A")
Else
l1.Sheets(hoja).Copy Before:=l2.Sheets(1)
End If
l1.Sheets(hoja).Cells.ClearContents
Next
'
l2.Close True
Application.ScreenUpdating = True
MsgBox "Files have been transfered", vbInformation
End Sub
1 Respuesta
Te anexo la macro actualizada.
Sub CopiarCeldas()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
ruta = l1.Path & "\"
'
On Error Resume Next
Set l2 = Workbooks.Open(ruta & "OhnDoc.xlsm")
On Error GoTo 0
'
hojas = Array("OhnCF", "OhnSw", "OhnOp")
For i = LBound(hojas) To UBound(hojas)
existe = False
hoja = hojas(i)
For Each h In l2.Worksheets
If h.Name = hoja Then
existe = True
Exit For
End If
Next
If existe Then
Set h2 = l2.Worksheets(hoja)
Set h1 = l1.Worksheets(hoja)
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
l1.Sheets(hoja).Range("A1:E" & u1).Copy h2.Cells(u2, "A")
Else
l1.Sheets(hoja).Copy Before:=l2.Sheets(1)
End If
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
If u1 = 1 Then u1 = 2
l1.Sheets(hoja).Range("A2:E" & u1).ClearContents
Next
'
l2.Close True
Application.ScreenUpdating = True
MsgBox "Copia terminada", vbInformation
End SubPrueba y me comentas si le falta algún detalle.
S a l u d o s . D a n t e A m o r
Si es lo que necesitas.
Hola Dante,
Muchas gracias por su código, es posible que en la línea 24, ¿el código use toda la fila? (No solo el rango A:E). Intente modificarlo pero me marca error.
Gracias por su tiempo,
Marcela.
l1.Sheets(hoja).Range("A1:E" & u1).Copy h2.Cells(u2, "A")
Te anexo la macro actualizada
Sub CopiarCeldas()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
ruta = l1.Path & "\"
'
On Error Resume Next
Set l2 = Workbooks.Open(ruta & "OhnDoc.xlsm")
On Error GoTo 0
'
hojas = Array("OhnCF", "OhnSw", "OhnOp")
For i = LBound(hojas) To UBound(hojas)
existe = False
hoja = hojas(i)
For Each h In l2.Worksheets
If h.Name = hoja Then
existe = True
Exit For
End If
Next
If existe Then
Set h2 = l2.Worksheets(hoja)
Set h1 = l1.Worksheets(hoja)
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
c1 = h1.UsedRange.Columns(h1.UsedRange.Columns.Count).Column
l1.Sheets(hoja).Range(h1.Cells(1, 1), h1.Cells(u1, c1)).Copy h2.Cells(u2, "A")
Else
l1.Sheets(hoja).Copy Before:=l2.Sheets(1)
End If
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
c1 = h1.UsedRange.Columns(h1.UsedRange.Columns.Count).Column
If u1 = 1 Then u1 = 2
l1.Sheets(hoja).Range(h1.Cells(2, 1), h1.Cells(u1, c1)).ClearContents
Next
'
l2.Close True
Application.ScreenUpdating = True
MsgBox "Copia terminada", vbInformation
End Sub
Hola Dante!
Funciona perfecto, una última pregunta, y disculpe tanta molestia: pega desde la fila 1 de la hoja origen(encabezados), me gustaría que empezara en la fila 2, pero no quiero modificar el código probando y arruinarlo. ¿Podrá decirme usted donde tengo que modificarlo?
Muchas gracias!
No entendí qué necesitas.
¿Copiar desde la fila 1?
¿Copiar desde la fila 2?
¿Pegar en la fila 1?
¿Pegar en la fila 2?
Disculpe, me epliqué mal.
Necesito copiar desde la celda 2, siempre, y pegar siempre en la primer fila vacía del documento destino.
Hasta ahora funciona perfecto, pero copia y pega desde la fila 1 (el encabezado) cada vez que ejecuto la macro.
Gracias!
Cambia en la macro esto:
L1. Sheets(hoja). Range(h1. Cells(1, 1), h1. Cells(u1, c1)). Copy h2. Cells(u2, "A")
Por esto
L1. Sheets(hoja). Range(h1. Cells(2, 1), h1. Cells(u1, c1)). Copy h2. Cells(u2, "A")
