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

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

1 个答案: