Vba筛选出当天日期的资料复制到另一个表中

以下是一个简单的VBA代码，可以筛选出当天日期的数据，并将其复制到另一个工作表中。

Sub FilterByToday()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr As Long, i As Long
Dim todayDate As Date

Set ws1 = ThisWorkbook.Sheets("Sheet1") '原始数据所在的工作表
Set ws2 = ThisWorkbook.Sheets("Sheet2") '复制数据所在的工作表

todayDate = Date '获取当前日期

With ws1
lr = .Range("A" & .Rows.Count).End(xlUp).Row '获取最后一行
For i = 2 To lr '从第2行开始循环，第1行可能是表头
If .Cells(i, 1).Value = todayDate Then '如果日期等于今天日期
.Rows(i).Copy ws2.Range("A" & ws2.Rows.Count).End(xlUp).Offset(1) '复制整行数据到另一个工作表
End If
Next i
End With

End Sub

请将代码复制到VBA编辑器中，并根据需要修改工作表名称和日期列的位置。在运行代码之前，请确保保存工作簿。

相关问题

Vba筛选出当天日期的资料

以下是VBA代码，可以筛选出当天日期的资料：

Sub FilterByToday()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim todayDate As Date
    
    Set ws = ThisWorkbook.Worksheets("Sheet1") '更改工作表名称
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row '获取最后一行
    
    todayDate = Date '获取今天日期
    
    '筛选出日期等于今天的行
    With ws.Range("A1:A" & lastRow)
        .AutoFilter Field:=1, Criteria1:=todayDate, Operator:=xlFilterValues
    End With
    
End Sub

将代码粘贴到VBA编辑器中，然后运行它即可。它将在工作表“Sheet1”中筛选出日期等于今天的行。如果您需要更改工作表名称，请更改代码中的“Sheet1”到您需要的名称。

vba筛选两个excel工作表中的数据复制到一个新的工作表中

下面是一个示例代码，演示如何使用VBA将两个工作表中的数据筛选后复制到一个新的工作表中：

Sub FilterAndCopy()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
    Dim i As Long, j As Long
    
    '获取需要操作的三个工作表对象
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")
    
    '获取两个原始工作表的最后一行
    lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    
    '清空目标工作表
    ws3.Cells.ClearContents
    
    '复制第一个工作表中满足条件的数据到目标工作表
    j = 1 '目标工作表的行数
    For i = 1 To lastRow1
        If ws1.Cells(i, 2) = "条件1" And ws1.Cells(i, 3) > 10 Then
            ws1.Rows(i).Copy ws3.Rows(j)
            j = j + 1
        End If
    Next i
    
    '复制第二个工作表中满足条件的数据到目标工作表
    For i = 1 To lastRow2
        If ws2.Cells(i, 2) = "条件2" And ws2.Cells(i, 3) < 20 Then
            ws2.Rows(i).Copy ws3.Rows(j)
            j = j + 1
        End If
    Next i
    
    '自适应调整目标工作表的列宽
    lastRow3 = ws3.Cells(Rows.Count, 1).End(xlUp).Row
    ws3.Cells.EntireColumn.AutoFit
End Sub

在上面的示例代码中，我们首先获取了需要操作的三个工作表对象，然后通过Cells函数和End(xlUp)方法获取了两个原始工作表的最后一行。接着，我们清空了目标工作表，然后依次遍历两个原始工作表中的每一行，筛选出满足条件的数据，并使用Copy方法将其复制到目标工作表中。最后，我们使用EntireColumn.AutoFit方法自适应调整目标工作表的列宽。