通过单元格值从一个工作簿复制到另一个工作簿

Question

I'm trying to write a VBA script in Excel to programmatically copy all rows containing today's date from one workbook into another. In trying to figure this out, I've written two working scripts which address aspects of the intended operation, and one non-working script that attempts to reconcile the two aspects.

The first working script copies a specifically identified cell from one workbook to another:

Sub Button1_Click()

Set x = ThisWorkbook
Set y = Workbooks.Open("\\networpath\Test2.xlsx")

x.Sheets("Sheet1").Range("A2").Copy Destination:=y.Sheets("Sheet1").Range("A2")

End Sub

The second working script copies all rows containing today's date in a particular column from one sheet to another sheet, within the same workbook:

Sub Button2_Click()

Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If Range("B" & r).Value = Date Then
        Rows(r).Copy Destination:=Sheets("Sheet2").Range("A" & lr2 + 1)
        lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r

End Sub

My thought was, that since both of these work, it should also work if I put them together. The result, so far, is this non-working script:

Sub Button3_Click()

Set x = ThisWorkbook
Set y = Workbooks.Open("\\networkpath\Test2.xlsx")

Dim lr As Long, lr2 As Long, r As Long
lr = x.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = y.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If Range("B" & r).Value = Date Then
        Rows(r).Copy Destination:=Sheets("Sheet1").Range("A" & lr2 + 1)
        lr2 = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    End If
Next r

End Sub

This script doesn't generate any errors. It succeeds in opening the second file, Test2.xlsx . However, no data is copied into this second file. Any idea what I'm doing wrong here?

EDIT: Solved

Working script with a few modifications from the above:

Sub Button3_Click()

Dim x As Workbook, y As Workbook, lr As Long, lr2 As Long, r As Long

Set x = ThisWorkbook
Set y = Workbooks.Open("\\networkpath\Test2.xlsx")

lr = x.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = y.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If x.Sheets("Sheet1").Range("B" & r).Value = Date Then
        x.Sheets("Sheet1").Rows(r).Copy Destination:=y.Sheets("Sheet1").Range("A" & lr2 + 1)
        lr2 = y.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    End If
Next r

End Sub

Answer 1

I changed a few things in your code, hope it solves your problem in this way.

Sub Button3_Click()

    Dim x As Workbook
    Dim y As Workbook
    Dim datToday As Date

    datToday = Date

    Set x = ThisWorkbook
    Set y = Workbooks.Open("\\networkpath\Test2.xlsx")

    Dim lr As Long, lr2 As Long, r As Long
    lr = x.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    lr2 = 0
    For r = 1 To lr
        x.Activate
        If Range("B" & r).Value = datToday Then
            x.Sheets("Sheet1").Rows(r).Copy Destination:=y.Sheets("Sheet1").Range("A" & lr2 + 1)
            lr2 = y.Sheets("Sheet1").UsedRange.Rows.Count
        End If
    Next r

    End Sub