Adicionar una instrucción a macro de trasladar datos
Mi Quiero Dante
En base a esta macro que me creaste
Sub Trasladar()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
If h1.[F1] = "" Or Not IsDate(h1.[F1]) Then
MsgBox "Escribe una fecha correcta en la celda F1"
Exit Sub
End If
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
fec = Format(h1.[F1], "mm/dd/yyyy")
h1.Range("A1:E" & u1).AutoFilter Field:=1, _
Operator:=xlFilterValues, Criteria2:=Array(2, fec)
h1.Range("A1:E" & u1).AutoFilter Field:=5, Criteria1:="x"
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
If u1 > 1 Then
h1.Range("A2:E" & u1).Copy h2.Range("A" & u2)
MsgBox "Registros Trasladados"
Else
MsgBox "No hay registros con las condiciones"
End If
h1.Range("A1").AutoFilter
End SubAhora quisiera que me ayudaras con algo que se me acaba de ocurrir. Que haga lo mismo que hace actualmente solo con 1 diferencia. Cuando me traslade los datos de fecha que estan en la columna "A" los traslade pero con 40 dias más. Es decir por ejemplo.
Si hay un ejemplo que cumple la condición de ser trasladado (Por ser de la fecha y por tener la "x") que la fecha que me ponga en la columna "A" de la hoja2 sea la fecha de la columna "A" de la hoja1 + 40 días después.
Ejemplo:
01/03/2015 (Columna A Hoja1) se trasladaria como 10/04/2015 (Columna "A" hoja2)
1 Respuesta
Respuesta de Dante Amor
2
H o l a:
Te anexo la macro actualizada
Sub Trasladar()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
If h1.[F1] = "" Or Not IsDate(h1.[F1]) Then
MsgBox "Escribe una fecha correcta en la celda F1"
Exit Sub
End If
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
fec = Format(h1.[F1], "mm/dd/yyyy")
h1.Range("A1:E" & u1).AutoFilter Field:=1, _
Operator:=xlFilterValues, Criteria2:=Array(2, fec)
h1.Range("A1:E" & u1).AutoFilter Field:=5, Criteria1:="x"
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
If u1 > 1 Then
h1.Range("A2:E" & u1).Copy h2.Range("A" & u2)
u3 = h2.Range("A" & Rows.Count).End(xlUp).Row
For i = u2 To u3
h2.Cells(i, "A") = h2.Cells(i, "A") + 40
Next
MsgBox "Registros Trasladados"
Else
MsgBox "No hay registros con las condiciones"
End If
h1.Range("A1").AutoFilter
End Sub
