如果满足条件，将行从一个工作簿复制到另一个工作簿

Question

如果满足以下条件，我如何将行从一个工作簿复制/粘贴到另一个工作簿： 如果源工作簿（wb.Source，sheet1）中的所有行来自实际月份（包含真实日期的第 8 列），则复制它们并将它们粘贴到工作表 3 中的我的主工作簿（Wb）。仅复制具有第一个的行在第 8 列中作为日期的月份日期。

示例：

假设今天是 14.05.2020。

触发宏将从源工作簿中复制日期为 01.05.2020（第 8 列）的所有行，并将它们粘贴到工作表 3 中的 wb。

因此，宏需要参考 Today 函数才能说出现在实际上是哪个月份，然后在下一步中复制同一月份的行，但仅从该月份的第一天开始.

不胜感激！

Private Sub CommandButton3_Click()





Dim fname As String, wbSource As Workbook, wsSource As Worksheet
    fname = Me.TextBox1.Text

    If Len(fname) = 0 Then
       MsgBox "No file selected", vbCritical, "Error"
       Exit Sub
    End If

    Set wbSource = Workbooks.Open(fname, False, True) ' no link update, read only
    Set wsSource = wbSource.Sheets("Sheet1") ' change to suit

    Dim wb As Workbook, ws As Worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Table 3")



    ' Set your source and destination worksheets as objects here

    Set wsSource = wbSource.Sheets("Sheet1")


    Dim i As Long, destination_row As Long
    Dim source_rng As Range, destination_rng As Range
    destination_row = 1

    For i = 1 To 10 ' See note below regarding for vs while loop for this
        ' Check dates only against cells that contain date values (in case there is a non-date value in one of the cells)
        If VarType(wsSource.Cells(i, 8)) = vbDate Then

            ' Condition checks that the date is today
            If Format(Now, "yyyy/mm/dd") = Format(wsSource.Cells(i, 8).Value2, "yyyy/mm/dd") Then

                ' Set source and destination ranges
                Set source_rng = wsSource.Range(wsSource.Cells(i, 1), wsSource.Cells(i, 10000))
                Set destination_rng = ws.Range(ws.Cells(destination_row, 1), destination_sheet.Cells(destination_row, 10000))

                source_rng.Copy destination_rng ' Alternatively use destination_rng.Value2 = source_rng.Value2
                destination_row = destination_row + 1 ' Iterate the destination row so that the next copy outputs to the next row

            End If
        End If
    Next i



     ' close source worbook no save
    wbSource.Close False


End Sub

Answer 1

问题对于工作表的格式有点模糊（哪些列包含数据，您要从哪里开始打印，如果您知道源数据有多少行，是否填充了数据范围内的所有单元格，等），但我在这里编写了一个示例，可以对其进行调整以适合您正在使用的工作表。

Option Explicit

Sub CopyRows()

    ' Set your source and destination worksheets as objects here
    Dim source_sheet As Worksheet, destination_sheet As Worksheet
    Set source_sheet = ActiveWorkbook.Sheets("A")
    Set destination_sheet = ActiveWorkbook.Sheets("B")

    Dim i As Long, destination_row As Long
    Dim source_rng As Range, destination_rng As Range
    destination_row = 1

    For i = 1 To 10 ' See note below regarding for vs while loop for this
        ' Check dates only against cells that contain date values (in case there is a non-date value in one of the cells)
        If VarType(source_sheet.Cells(i, 8)) = vbDate Then

            ' Condition checks that the date is today
            If Format(Now, "yyyy/mm/dd") = Format(source_sheet.Cells(i, 8).Value2, "yyyy/mm/dd") Then

                ' Set source and destination ranges
                Set source_rng = source_sheet.Range(source_sheet.Cells(i, 1), source_sheet.Cells(i, 10))
                Set destination_rng = destination_sheet.Range(destination_sheet.Cells(destination_row, 1), destination_sheet.Cells(destination_row, 10))
                source_rng.Copy destination_rng ' Alternatively use destination_rng.Value2 = source_rng.Value2
                destination_row = destination_row + 1 ' Iterate the destination row so that the next copy outputs to the next row

            End If
        End If
    Next i

End Sub

我使用工作表“A”和“B”作为源工作表和目标工作表的代理。您需要在代码中将这些对象设置为您的实际源工作表和目标工作表。

我还将destination_row 初始化为1，假设您希望从目标工作表的第一行开始打印复制的行，但这可以设置为2（如果有标题）或您喜欢的任何行输出开始。如果您希望在工作表中已存在的任何数据下方添加新行，您可能需要添加额外的代码来查找下一个空行。

for 循环是作为一个基本示例编写的，假设您知道有多少行数据。如果您希望源范围的大小发生变化（即经常添加和/或删除行），您可能希望在开始循环之前确定最后一行（通过使用 xlUp/xlDown 或类似方法），或者使用一段时间循环而不是 for 循环（如果有一个始终填充的列，您可以将其用作 while 条件的一部分）。

在设置source_rng和destination_rng的部分，将数字1和10替换为数据的第一列和最后一列（例如，如果数据从第3列开始，到第15列结束，则应更改这些分别为 3 和 15）。