Help needed modifying this VBA: copy to workbook

[JumboCactuar]

Hi,
i have the following code which works fine
(Copies column A and F to Workbook 2: Column A and B without blanks)

Sub CopyTest()

Dim WB1 As Workbook, WB2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Rng As Range, r As Range, rSel As Range


lastrow = Cells(Rows.Count, "A").End(xlUp).Row


    Set WB1 = ThisWorkbook
    Set ws1 = ActiveSheet
    Set WB2 = Workbooks.Open("C:\Temp\DataFile.xlsx")
    Set ws2 = WB2.Sheets("Sheet1")
    
    WB1.Activate
    Set Rng = Range("a2:a" & lastrow)
    Set rSel = Nothing


For Each r In Rng
        If r.Value <> "" Then
            If rSel Is Nothing Then
                Set rSel = r
            Else
                Set rSel = Union(rSel, r)
            End If
            Set rSel = Union(rSel, r.Offset(0, 6))
        End If
Next r
If Not rSel Is Nothing Then rSel.Select


rSel.Copy
ws2.Range("a100000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues


WB2.Close savechanges:=True


End Sub

What im wanting is to include the date/time they was copied into workbook 2: column C
If it helps i have a cell already with date/time in original sheet (cell Z1)

so when this occurs
rSel.Copy
ws2.Range("a100000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

all the blank cells in column C should have the date/time



appreciate any help

 

[AlphaFrog]

[color=darkblue]Sub[/color] CopyTest()
    
    [color=darkblue]Dim[/color] WB1 [color=darkblue]As[/color] Workbook, WB2 [color=darkblue]As[/color] Workbook
    [color=darkblue]Dim[/color] ws1 [color=darkblue]As[/color] Worksheet, ws2 [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] Rng [color=darkblue]As[/color] Range, r [color=darkblue]As[/color] Range, rSel [color=darkblue]As[/color] Range
[B]    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color], i [color=darkblue]As[/color] Long[/B]
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    [color=darkblue]Set[/color] WB1 = ThisWorkbook
    [color=darkblue]Set[/color] ws1 = ActiveSheet
    [color=darkblue]Set[/color] WB2 = Workbooks.Open("C:\Temp\DataFile.xlsx")
    [color=darkblue]Set[/color] ws2 = WB2.Sheets("Sheet1")
    
    WB1.Activate
    [color=darkblue]Set[/color] Rng = Range("a2:a" & LastRow)
    [color=darkblue]Set[/color] rSel = [color=darkblue]Nothing[/color]
    
    [color=darkblue]For[/color] [color=darkblue]Each[/color] r [color=darkblue]In[/color] Rng
        [color=darkblue]If[/color] r.Value <> "" [color=darkblue]Then[/color]
            [color=darkblue]If[/color] rSel [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color]
                [color=darkblue]Set[/color] rSel = r
            [color=darkblue]Else[/color]
                [color=darkblue]Set[/color] rSel = Union(rSel, r)
            [color=darkblue]End[/color] [color=darkblue]If[/color]
            [color=darkblue]Set[/color] rSel = Union(rSel, r.Offset(0, 6))
[B]            i = i + 1[/B]
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] r
    [color=darkblue]If[/color] [color=darkblue]Not[/color] rSel [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color] rSel.Select
    
    rSel.Copy
[B]    [color=darkblue]With[/color] ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)[/B]
[B]        .PasteSpecial Paste:=xlPasteValues[/B]
[B]        .Offset(, 2).Resize(i).Value = Now[/B]
[B]    [color=darkblue]End[/color] [color=darkblue]With[/color][/B]
    
    WB2.Close savechanges:=[color=darkblue]True[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[JumboCactuar]

Thanks @AlphaFrog working perfectly