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
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.
