Macro para copiar filas de un libro a otro con condición
Tengo dos libros, libro1 y libro2, necesito extraer los ingresos del día laborable anterior que se encuentran en el libro2 copiar toda la fila y ponerlos en el libro1.
Hola DAM,
La fecha de ingreso de los registros esta en la columna "c" del libro "Bitácora"
el libro en el que necesito ejecutar la maro se llama "Reporte diario" de aca abro el libro "Bitácora" que es en donde se encuentran todos los registros, busca los registros que se hayan realizado el día laborable anterior y los pega en la hoja "Reporte" a partir de la fila "A6" del libro "Reporte diario".
Digo el día laborable anterior porque si es dia lunes que ejecuto la macro, debe buscar los ingresos de día viernes, espero me haya explicado mejor.
Muchas gracias, Saludos.
Tengo este código pero no me anda bien no se porque solo me copia 1 registro:
Sub CompletarLibro()
Dim ruta As String, direccion1 As String
Dim celdadestino As Range
'definimos rutas y archivos como variables
ruta = "\\Administracion\red trabajo\registros\"
fichero1 = "BITACORA.xlsx"
direccion1 = ruta & fichero1
a = Range("B3")'Aqui pongo el nombre de la hoja a seleccionar
'identificamos la celda disponible en el archivo Principal, hoja Resumen
Set celdadestino = Workbooks("REPORTE DIARIO.xlsm").Sheets("Reporte").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
'abrimos el fichero desde donde copiar... con el método .Open
Workbooks.Open Filename:=direccion1
Worksheets(a).Activate
'seleccionamos qué copiar y donde
For Each celda In Range("c1:c2000")
If celda.Value = (Date -1) Then
celda.EntireRow.Copy _
Destination:=Workbooks("REPORTE DIARIO.xlsm").Sheets("Reporte").Range(celdadestino.Address)
End If
NextSaludos,
Te regreso la macro corregida, ya te copia todos los registros del día anterior laborable.
Sub CompletarLibro()
'Mod.Por.DAM
Dim ruta As String, direccion1 As String
Dim celdadestino As Range
'definimos rutas y archivos como variables
ruta = "\\Administracion\red trabajo\registros\"
fichero1 = "BITACORA.xlsx"
direccion1 = ruta & fichero1
a = Range("B3") 'Aqui pongo el nombre de la hoja a seleccionar
'identificamos la celda disponible en el archivo Principal, hoja Resumen
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Reporte")
u = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
'abrimos el fichero desde donde copiar... con el método .Open
Workbooks.Open Filename:=direccion1
Worksheets(a).Activate
'seleccionamos qué copiar y donde
For Each celda In Range("c1:c" & Range("C" & Rows.Count).End(xlUp).Row)
'determinar el día laborable anterior
dia = Weekday(celda)
n = 1
Select Case dia
Case 2: n = 3
Case 1: n = 2
End Select
If celda.Value = (Date - n) Then
celda.EntireRow.Copy h1.Range("A" & u)
u = u + 1
End If
Next
End Sub
Hola Dante, acabo de probar pero no extrae ningún registro ni me da ningún error, le cambie la fecha en: If celda.Value = (Date - n) Then y me extrajo todos los datos, como le puedo solucionar eso??
Saludos.
Disculpa, te anexo la macro con la corrección.
Sub CompletarLibro()
'Mod.Por.DAM
'definimos rutas y archivos como variables
ruta = "\\Administracion\red trabajo\registros\"
fich = "BITACORA.xlsx"
a = Range("B3") 'Aqui pongo el nombre de la hoja a seleccionar
'identificamos la celda disponible en el archivo Principal, hoja Resumen
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Reporte")
u = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
'abrimos el fichero desde donde copiar... con el método .Open
Workbooks.Open Filename:=ruta & fich
Worksheets(a).Activate
'determinar el día laborable anterior
Select Case Weekday(Date)
Case 1: n = 2
Case 2: n = 3
Case Else: n = 1
End Select
'seleccionamos qué copiar y donde
For Each celda In Range("c1:c" & Range("C" & Rows.Count).End(xlUp).Row)
If celda.Value = (Date - n) Then
celda.EntireRow.Copy h1.Range("A" & u)
u = u + 1
End If
Next
End Sub
