Macro para extraer datos origen destino
Solicito de su ayuda, tengo dos archivos el de la hoja1 es el origen y quiero llevar estos datos al final de archivo con hoja datos, tengo una macro pero esta inicia realizando el recorrido por las columnas y me extrae la información del archivo origen y me lo pone en el archivo destino, para que lleve el segundo dato debo devolverme al archivo origen para que se exporte el segundo dato así sucesivamente.
Quisiera de su ayuden amablemente a validar el código e identificar mi falla y lo que le falta para que la información se exporte completa y automática del origen al destino
Gracias y quedo atento a sus amable repuestas.
Sub extraerdatos()
Dim ultfiladatos As String
Dim ultfilamacro As String
Dim fecha As Date
Dim placa As Integer
Dim km As Long
Dim Cl As Integer
Dim Pf As Integer
Dim Pm As Integer
Dim tll As Integer
Dim uFila As String
Dim Cont As Long
Workbooks("llantas (16).xlsm").Worksheets("hoja1").Activate
ultfiladatos = Sheets("hoja1").Range("A" & Rows.count).End(xlUp).Row
For Cont = 2 To ultfiladatos
fecha = Sheets("hoja1").Cells(Cont, 1)
placa = Sheets("hoja1").Cells(Cont, 2)
km = Sheets("hoja1").Cells(Cont, 3)
Cl = Sheets("hoja1").Cells(Cont, 4)
Pf = Sheets("hoja1").Cells(Cont, 6)
Pm = Sheets("hoja1").Cells(Cont, 7)
tll = Sheets("hoja1").Cells(Cont, 8)
Workbooks("Acumulado--21.xlsm").Worksheets("Datos").Activate
ultfilamacro = Sheets("Datos").Range("A" & Rows.count).End(xlUp).Row
Sheets("Datos").Cells(ultfilamacro + 1, 1) = fecha
Sheets("Datos").Cells(ultfilamacro + 1, 2) = placa
Sheets("Datos").Cells(ultfilamacro + 1, 3) = km
Sheets("Datos").Cells(ultfilamacro + 1, 4) = Cl
Sheets("Datos").Cells(ultfilamacro + 1, 9) = Pf
Sheets("Datos").Cells(ultfilamacro + 1, 13) = Pm
Sheets("Datos").Cells(ultfilamacro + 1, 21) = tll
Next Cont
End Sub
1 Respuesta
Prueba la siguiente macro, no es necesario un ciclo. Simplemente copia las columnas que requieres y las pega en la hoja destino.
Sub extraerdatos()
'Por Dante Amor
Dim sh1 As Worksheet, sh2 As Worksheet
Dim uf1 As Long, uf2 As Long
'
Set sh1 = Workbooks("llantas (16).xlsm").Sheets("hoja1") 'hoja origen
Set sh2 = Workbooks("Acumulado--21.xlsm").Worksheets("Datos") 'hoja destino
'
uf1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
uf2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
'
'Copia las columnas necesarias
sh1.Range("A2:D" & uf1 & ",F2:H" & uf1).Copy
sh2.Range("A" & uf2).PasteSpecial xlPasteValues
End Sub[Avísame si tienes alguna duda sobre el código. No olvides valorar.
Dante buen día,
Gracias por tu respuesta, cuando me copia el rango en el archivo origen hoja1 me copia todo el rango con datos y celdas vacías de la tabla, y al pegar me pega todo el rango continuo, las columnas que debe pagar en el archivo destino son de A:D, I-M-AG
Solo que traslade los datos sin las celdas vacías ya que después de correr la macro debo eliminar
Quedo atento a tu colaboración y muchas gracias
Tu macro no valida si tienes celdas vacías. Por eso mi macro no tiene ese validación.
¿En dónde tienes celdas vacías en la columna "A"?
Te paso la macro actualizada:
Sub extraerdatos()
'Por Dante Amor
Dim sh1 As Worksheet, sh2 As Worksheet
Dim uf1 As Long, uf2 As Long
'
Application.ScreenUpdating = False
'
Set sh1 = Workbooks("llantas (16).xlsm").Sheets("hoja1") 'hoja origen
Set sh2 = Workbooks("Acumulado--21.xlsm").Worksheets("Datos") 'hoja destino
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
uf1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
uf2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
'
'Filtra filas diferentes a vacío
sh1.Range("A1:H" & uf1).AutoFilter Field:=1, Criteria1:="<>"
'Copia las columnas necesarias
Sh1.Range("A2:D" & uf1). Copy
Sh2.Range("A" & uf2). PasteSpecial xlPasteValues
sh1.Range("F2:F" & uf1). Copy
sh2.Range("I" & uf2). PasteSpecial xlPasteValues
sh1.Range("G2:G" & uf1). Copy
sh2.Range("M" & uf2). PasteSpecial xlPasteValues
sh1.Range("H2:H" & uf1). Copy
sh2.Range("AG" & uf2). PasteSpecial xlPasteValues
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub[Avísame si tienes alguna duda sobre el código. No olvides valorar.
Muchas gracias Dante quedo perfecta.
[Con todo gusto, no olvides valorar.
