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

Question

我试图在Excel中编写VBA脚本，以编程方式将包含今天日期的所有行从一个工作簿复制到另一个工作簿。 为了弄清楚这一点，我编写了两个工作脚本来处理预期操作的各个方面，并编写了一个非工作脚本来尝试协调这两个方面。

第一个工作脚本将专门标识的单元格从一个工作簿复制到另一个工作簿：

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

第二个工作脚本将特定列中包含今天日期的所有行从同一工作簿的一个工作表复制到另一个工作表：

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

我的想法是，既然这两项工作都能完成，但如果将它们放在一起，它也应该工作。 到目前为止，结果是此无效脚本：

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

该脚本不会产生任何错误。 它成功打开了第二个文件Test2.xlsx 。 但是，没有数据被复制到第二个文件中。 知道我在做什么错吗？

编辑：解决

经过以上修改的工作脚本：

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

我更改了代码中的一些内容，希望它可以通过这种方式解决您的问题。

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