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 Sub

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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas