如何基于日期筛选并复制Excel指定行至另一个工作簿

问题描述 #

我有以下格式的数据（逗号为列分隔符），存储在TestData工作簿的Sheet1中：

Name, Date, Quantity
Bike, 20 Sep 22, 1
Car, 04 Nov 22,2
Milk, 04 Nov 22, 4

我已有一段能将整表数据复制到另一个工作簿作为新工作表的VBA代码：

Sub Copy_single()
    Set workbookA = ActiveWorkbook
    Dim otherWorkbook As Workbook
    folder = Application.GetOpenFilename("Excel (*.xlsm), *.xlsm", 1, "Select file")
    Set otherWorkbook = Workbooks.Open(Filename:=folder)
    workbookA.ActiveSheet.Copy Before:=otherWorkbook.Sheets("Sheet1")
End Sub

现在需要修改这段代码，让它只复制包含今日日期的行。比如示例中只复制以下内容：

Name, Date, Quantity
Car, 04 Nov 22,2
Milk, 04 Nov 22, 4

修改后的代码 #

Sub Copy_Today_Rows()
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim todayDate As Date
    
    ' 指定源工作簿和工作表（TestData的Sheet1）
    Set sourceWB = ThisWorkbook
    Set sourceWS = sourceWB.Sheets("Sheet1")
    
    ' 获取今日日期（仅保留年月日部分）
    todayDate = Date
    
    ' 选择目标工作簿，用户取消则退出
    Dim folderPath As Variant
    folderPath = Application.GetOpenFilename("Excel (*.xlsm), *.xlsm", 1, "选择目标文件")
    If folderPath = False Then Exit Sub
    
    Set targetWB = Workbooks.Open(Filename:=folderPath)
    
    ' 在目标工作簿新建工作表并命名
    Set targetWS = targetWB.Sheets.Add(Before:=targetWB.Sheets("Sheet1"))
    targetWS.Name = "今日数据_" & Format(todayDate, "yyyy-mm-dd")
    
    ' 复制表头
    sourceWS.Rows(1).Copy Destination:=targetWS.Rows(1)
    
    ' 遍历源数据，复制符合日期条件的行
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "B").End(xlUp).Row ' 假设日期在B列
    Dim targetRow As Long
    targetRow = 2 ' 从第二行开始粘贴数据
    
    For i = 2 To lastRow
        ' 兼容文本格式的日期，转换后与今日日期比对
        If DateValue(sourceWS.Cells(i, "B").Value) = todayDate Then
            sourceWS.Rows(i).Copy Destination:=targetWS.Rows(targetRow)
            targetRow = targetRow + 1
        End If
    Next i
    
    ' 自动调整目标表列宽
    targetWS.UsedRange.Columns.AutoFit
    
    MsgBox "今日数据已复制完成！", vbInformation
End Sub

关键说明 #

• 日期匹配：用DateValue()转换源数据的日期（兼容文本格式的日期），和Date获取的今日日期（自动忽略时间部分）做精准比对。
• 源表定位：用ThisWorkbook替代ActiveWorkbook，避免激活其他工作簿时出错，明确指向存储代码的TestData工作簿。
• 容错处理：增加用户取消文件选择时的退出逻辑，防止程序报错。
• 目标表管理：新工作表命名为「今日数据_年月日」，方便区分不同日期的复制结果；最后自动调整列宽提升可读性。

内容的提问来源于stack exchange，提问作者vbanewb