VBA code line to insert timestamp after paste

[gigiUSA]

Hello all!

I have this VBA code intended to identify expired reagents in the sheet "Active", cut those rows and paste them in the sheet "Expired". What I want is to insert a timestamp in the next column (Column "G") for EACH of the pasted rows. The code below does the work....except for the fact that it is ONLY adding the timestamp to the first pasted row (in this case G2) and not the other pasted rows.

What am I missing? Thanks in advance!

Sub TransferData()

CarryOn = MsgBox("Have all EXPIRED reagents been removed from active stock?", vbYesNo + vbExclamation, "Expired Reagents Warning")
If CarryOn = vbYes Then
    
    Dim c As Range, TransferRange As Range, DataRange As Range
    Dim DestRange As Range
    Dim Lr As Long
    Dim iCount As Long


    With ThisWorkbook
        With .Sheets("Active")    'source sheet
            Lr = .Cells(.Rows.Count, 4).End(xlUp).Row
            Set DataRange = .Range(.Cells(2, 4), .Cells(Lr, 4))
        End With


        With .Sheets("Expired")    'destination sheet
            Lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            Set DestRange = .Cells(Lr, 1)
        End With
    End With
    DataRange.EntireRow.Hidden = False


    For Each c In DataRange.Cells
        If IsDate(c.Value) Then
            If c.Value < Date Then
                If TransferRange Is Nothing Then
                    Set TransferRange = c
                Else
                    Set TransferRange = Union(TransferRange, c)
                End If
                iCount = iCount + 1
            End If
        End If
    Next c
    If Not TransferRange Is Nothing Then
        With TransferRange.EntireRow
            .Copy DestRange
            Sheets("Expired").Range("G2").End(xlUp).Offset(1).Value = Now
            .Delete
        End With
    End If


    MsgBox iCount & " Expired Records Transferred", 48, "Expired"

End If
End Sub

 

[Michael M]

Does this fix it...

Sub TransferData()

CarryOn = MsgBox("Have all EXPIRED reagents been removed from active stock?", vbYesNo + vbExclamation, "Expired Reagents Warning")
If CarryOn = vbYes Then
   
    Dim c As Range, TransferRange As Range, DataRange As Range
    Dim DestRange As Range
    Dim Lr As Long, lr2 As Long
    Dim iCount As Long


    With ThisWorkbook
        With .Sheets("Active")    'source sheet
            Lr = .Cells(.Rows.Count, 4).End(xlUp).Row
            Set DataRange = .Range(.Cells(2, 4), .Cells(Lr, 4))
        End With


        With .Sheets("Expired")    'destination sheet
            lr2 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            Set DestRange = .Cells(Lr, 1)
        End With
    End With
    DataRange.EntireRow.Hidden = False
    For Each c In DataRange.Cells
        If IsDate(c.Value) Then
            If c.Value < Date Then
                If TransferRange Is Nothing Then
                    Set TransferRange = c
                Else
                    Set TransferRange = Union(TransferRange, c)
                End If
                iCount = iCount + 1
            End If
        End If
    Next c
    If Not TransferRange Is Nothing Then
        With TransferRange.EntireRow
            .Copy DestRange
            Sheets("Expired").Range("G" & lr2).End(xlUp).Offset(1).Value = Now
            .Delete
        End With
    lr2 = Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End If
    MsgBox iCount & " Expired Records Transferred", 48, "Expired"
End If
End Sub

 

[gigiUSA]

Thanks Michael!

It is giving me a compile error here:

lr2 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1

 

[Michael M]

change to
lr2 = .Cells(Rows.Count, 1).End(xlUp).Row + 1

 

[gigiUSA]

Not working.....still adding date only in "G2" and now it is adding a lot of extra empty rows after the paste

 

[Michael M]

Seems a lot of work to transfer a few lines across....Can you poast a small block of sample data
Try

Sub TransferData()
CarryOn = MsgBox("Have all EXPIRED reagents been removed from active stock?", vbYesNo + vbExclamation, "Expired Reagents Warning")
If CarryOn = vbYes Then
    Dim c As Range, TransferRange As Range, DataRange As Range
    Dim DestRange As Range
    Dim Lr As Long
    Dim iCount As Long
    With ThisWorkbook
        With .Sheets("Active")    'source sheet
            Lr = .Cells(.Rows.Count, 4).End(xlUp).Row
            Set DataRange = .Range(.Cells(2, 4), .Cells(Lr, 4))
        End With
        With .Sheets("Expired")    'destination sheet
            lr2 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            Set DestRange = .Cells(lr2, 1)
        End With
    End With
    DataRange.EntireRow.Hidden = False
    For Each c In DataRange.Cells
        If IsDate(c.Value) Then
            If c.Value < Date Then
                If TransferRange Is Nothing Then
                    Set TransferRange = c
                Else
                    Set TransferRange = Union(TransferRange, c)
                End If
                iCount = iCount + 1
            End If
        End If
    Next c
    If Not TransferRange Is Nothing Then
        With TransferRange.EntireRow
            .Copy DestRange
            Sheets("Expired").Range("G2:G" & lr2) = Now
            .Delete
        End With
    End If
    MsgBox iCount & " Expired Records Transferred", 48, "Expired"
End If
End Sub

 

[Michael M]

Does this do the same thing

Sub MM1()
Dim lr As Long, lr2 As Long
lr = Sheets("Active").Cells(.Rows.Count, 4).End(xlUp).Row
lr2 = Sheets("Expired").Cells(.Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Active").Range("D2:D" & lr)
    .AutoFilter field:=1, Criteria1:="<" & CLng(Date), Operator:=xlAnd
    .SpecialCells(xlCellTypeVisible).Copy Sheets("Expired").Range("A" & lr2)
    .AutoFilter
End With
lr2 = Sheets("Expired").Cells(.Rows.Count, 1).End(xlUp).Row + 1
Sheets("Expired").Range("G2:G" & lr2) = Now
End Sub

 

[Michael M]

Minor change

Sub MM1()
Dim lr As Long, lr2 As Long
lr = Sheets("Active").Cells(Rows.Count, 4).End(xlUp).Row
lr2 = Sheets("Expired").Cells(Rows.Count, 1).End(xlUp).Row + 1
With Sheets("Active").Range("D2:D" & lr)
    .AutoFilter field:=1, Criteria1:="<" & CLng(Date), Operator:=xlAnd
    .SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Expired").Range("A" & lr2)
    .AutoFilter
End With
lr2 = Sheets("Expired").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Expired").Range("G2:G" & lr2) = Now
End Sub

 

[gigiUSA]

Update: Made it work with a second macro (instead of trying to modify the first one). Here it is. Thanks a lot for all the help!

Private Sub Worksheet_Change(ByVal Target As Range)

Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.Sheets("Expired").Range("F:F"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yy, hh:mm:ss"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
End If
End Sub