Como copiar una fila de un libro a otro
Dante Amor Esta pregunta va dirigida a ti, pero si alguien mas pudiera aportar seria bienvenido.
Deseo copiar una fila completa que se selecciona en un listbox y al apretar un botón eliminar, se elimina del listbox y de la hoja10. Hasta ahí todo va bien pero ahora quisiera que antes de eliminarla copiara esta fila seleccionada y la pegara en otro libro (Hoja1) en la ultima fila vacía indicando en la ultima columna vacía la hora y fecha del copiado. Anexo macro actual para eliminar. Espero haberme explicado. Agradezco su atención
Sub eliminarProducto()
Dim Dato As String
Dim C As Range
Dim uf As Long
uf = Hoja10.Range("A" & Rows.Count).End(xlUp).Row
With ListBox1
For x = 0 To .ListCount - 1
If .Selected(x) Then
Dato = ListBox1.Text
With Hoja10.Range("A2:A" & uf)
Set C = .Find(Dato, LookIn:=xlValues, lookat:=xlWhole)
If Not C Is Nothing Then
'AQUI ES DONDE QUIERO SE EJECUTE LO SOLICITADO ANTES DE ELIMINAR
C.Rows.EntireRow.Delete
UserForm_Initialize
MsgBox "Ha eliminado la clave " & Dato
Exit Sub
End If
End With
End If
Next
End With
End Sub
1 respuesta
Adapté el código, no lo he probado pero debería funcionarte. Asegúrate de leer el par de comentarios que puse, debes modificar la ruta del libro destino, y el nombre de la hoja. Veo que sabes algo de VBA, te sera fácil adaptarlo. En general esta es la idea:
Sub eliminarProducto()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'modificacion, nuevas variables'
Dim EsteLibro As Workbook: Set EsteLibro = ThisWorkbook
Dim OtroLibro As Workbook
Dim Sht1 As Worksheet
Dim uC As Long
Dim RowArr() As Variant
'Andy'
Dim Dato As String
Dim C As Range
Dim uf As Long
uf = Hoja10.Range("A" & Rows.Count).End(xlUp).Row
With ListBox1
For x = 0 To .ListCount - 1
If .Selected(x) Then
Dato = ListBox1.Text
With Hoja10.Range("A2:A" & uf)
Set C = .Find(Dato, LookIn:=xlValues, lookat:=xlWhole)
If Not C Is Nothing Then
'AQUI ES DONDE QUIERO SE EJECUTE LO SOLICITADO ANTES DE ELIMINAR'
'modificacion, nuevo procedimiento'
uC = Cells(C.Row, Columns.Count).End(xlToLeft).Column
RowArr() = Range(Cells(C.Row, 1), Cells(C.Row, uC)).Value2
Set OtroLibro = Workbooks.Open("C:\Carpeta\Sub Carpeta\Otra Carpeta\NombreLibro.xls") 'modifica la ruta'
Set Sht1 = OtroLibro.Sheets("Sheet1") 'modifica el nombre de la hoja'
uf = Sht1.Range("A" & Rows.Count).End(xlUp).Row + 1
Sht1.Range(Cells(uf, 2), Cells(uf, uC)).Value = RowArr()
Sht1.Cells(uf, uC + 1).Value = Now
Sht1.Cells(uf, uC + 1).NumberFormat = "mm/dd/yyyy - hh:mm:ss AM/PM"
OtroLibro.Close SaveChanges:=True
'Andy'
C.Rows.EntireRow.Delete
UserForm_Initialize
MsgBox "Ha eliminado la clave " & Dato
Exit Sub
End If
End With
End If
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End SubAndy
Andy Machin Muchísimas gracias, le hice algunas adecuaciones pero jalo al 100. quedando así.
'modificacion, por Andy'
uC = Cells(C.Row, Columns.Count).End(xlToLeft).Column
RowArr() = Range(Cells(C.Row, 1), Cells(C.Row, uC)).Value2
Set OtroLibro = Workbooks.Open(ThisWorkbook.Path & "\Libro2.xlsm") 'abrir el archivo en cualquier escritorio
Set Sht1 = OtroLibro.Sheets("Hoja1") 'nombre de la hoja'
uf = Sht1.Range("A" & Rows.Count).End(xlUp).Row + 1
Sht1.Range(Cells(uf, 1), Cells(uf, uC)).Value = RowArr()
Sht1.Cells(uf, uC + 1).Value = Now
Sht1.Cells(uf, uC + 1).NumberFormat = "mm/dd/yyyy - hh:mm:ss AM/PM"
OtroLibro.Close SaveChanges:=True
Perfecto, a la orden :)
PD: no olvide que las preguntas se cierran con "agradecimiento" en lugar de "Pedir más información" de lo contrario se queda abierta como si aun no fuera resuelta.
