Macro para copiar datos a partir de una fecha
Necesitaría ayuda para crear una macro para que me copie varias columnas a partir de una fecha, por ejemplo en la celda C3 de la Hoja2 pongo 06/06/2019, la macro debería ir a las celdas H1, I1, J1, K1, L1, M1, N1, O1, P1, Q1, R1, S1, T1, U1, V1, W1, X1, Y1, Z1, AA1, AB1, AC1, AD1, AF1, AG1, AH1, AI1 de la Hoja1 a buscar donde se encuentra esa fecha y copiar los datos celda a celda de la columna B (de la B2 hasta la B500), E ( de la E2 hasta la E500) y de las columnas anteriores la que corresponda con la fecha igual desde la fila 2 hasta la 500 y que pegue los datos en la hoja 2 a en las columnas B, C y D a partir de la fila 7. No se si lo habré dejado claro o no y si es posible hacer una macro así.
1 respuesta
¿Se entendería mejor si además de la explicación pusieras una imagen de tus datos y especificar en donde se buscaría la fecha?
Prueba con esta macro
Sub test()
Set h2 = Worksheets("hoja2")
Set h1 = Worksheets("hoja1")
fecha = h2.Range("c1")
Set datos = h1.Range("h1").CurrentRegion
With datos
filas = 500
cuenta = WorksheetFunction.CountIf(.Rows(1), CDbl(fecha))
If cuenta > 0 Then
celda = WorksheetFunction.Match(CDbl(fecha), .Rows(1), 0)
Set tabla = .Cells(2, 1).Resize(filas, celda - 1)
With h1
.Range("b2").Resize(filas, 1).Copy: h2.Range("b7").PasteSpecial
.Range("e2").Resize(filas, 1).Copy: h2.Range("c7").PasteSpecial
tabla.Copy: h2.Range("d7").PasteSpecial
End With
End If
Set h1 = Nothing: Set h2 = Nothing
Set tabla = Nothing: Set datos = Nothing
End With
End Sub
Muchas gracias por tu respuesta, lo acabo de probar y me da Error de compilación: Se esperaba una Function o una variable.
Disculpa aquí esta el error
Quiere decir que tienes una macro con el nombre de una variable lo único que tienes que hacer es ver que variable es y cambiarle el nombre
Viendo las imágenes de tus datos me doy cuenta que la macro tiene que ser replanteada para quedar así, solo me quedo la duda de la columna comentarios ¿también le vas a copiar algo?, ¿Y si es así de que columna de la hoja1?
Sub copiar_datos()
Set h1 = Worksheets("hoja1")
Set h2 = Worksheets("hoja2")
fecha = h2.Range("c3")
Set datos = h1.Range("b1").CurrentRegion
With datos
filas = .Rows.Count
cuenta = WorksheetFunction.CountIf(.Rows(1), fecha)
If cuenta > 0 Then
indice = WorksheetFunction.Match(CDbl(fecha), .Rows(1), 0)
.Cells(2, 1).Resize(filas - 1, 1).Copy: h2.Range("b7").PasteSpecial
.Cells(2, 4).Resize(filas - 1, 1).Copy: h2.Range("c7").PasteSpecial
End If
End With
Set h1 = Nothing: Set h2 = Nothing
Set datos = Nothing
End Sub
Si ya está hecho, no sale ningún error pero no copia nada de la.hoja 1 a la hoja 2, se ejecuta pero no pega ningún dato. Gracias
Si la columna comentarios quiero copiar de la hoja 1 las celdas de la columna de la fecha que he buscado en el C3 hoja 2
Pues esta curioso mira este es la imagen de tus datos
y este es el resultado de la macro, copia las columnas B y E además también copia la columna que tiene la fecha tecleada en la celda C3 de la hoja2, si no copia se puede deber a que no hay fecha en la celda mencionada
esta es la macro
Sub copiar_datos()
Set h1 = Worksheets("hoja1")
Set h2 = Worksheets("hoja2")
FECHA = h2.Range("c3")
If FECHA <> Empty Then
Set datos = h1.Range("b1").CurrentRegion
With datos
filas = .Rows.Count
cuenta = WorksheetFunction.CountIf(.Rows(1), FECHA)
If cuenta > 0 Then
INDICE = WorksheetFunction.Match(CDbl(FECHA), .Rows(1), 0)
.Cells(2, 1).Resize(filas - 1, 1).Copy: h2.Range("b7").PasteSpecial
.Cells(2, 4).Resize(filas - 1, 1).Copy: h2.Range("c7").PasteSpecial
.Cells(2, INDICE).Resize(filas - 1, 1).Copy: h2.Range("D7").PasteSpecial
Else
MsgBox ("NO EXISTE ESTA FECHA"), vbInformation, "AVISO"
End If
End With
Else
MsgBox ("NO HAY FECHA EN LA CELDA C3"), vbInformation, "AVISO"
End If
Set h1 = Nothing: Set h2 = Nothing
Set datos = Nothing
End Sub
¡Gracias! Simplemente perfecto!!! Lo de anoche era cuestión del ordenador portátil, en el PC de sobremesa si que pegaba los datos, así que revisaré bien que le pasa, pero solo me queda darte las GRACIAS!!! porque lo has clavado y ya los popups con el aviso a sido la guinda del pastel, de nuevo gracias porque me has salvado de la locura llevaba atascado desde el lunes con ese tema. Un saludo y GRACIAS!!
