vba - Excel vba日期过滤器并复制到新工作表

Question

我想使用 VBA 根据条件过滤数据：日期 -3 到日期 +3，然后复制到新工作表。如果没有结果返回，它也将空白复制到新的工作表，但不成功，只是将今天的数据复制到新的工作表，请告诉我如何解决这个问题？非常感谢。

这是我的代码：

Private Sub CommandButton13_Click()
Dim d As Date
Dim wSheetStart As Worksheet
Set wSheetStart = ThisWorkbook.Sheets("ATA")

Sheets.Add.Name = "New report"
wSheetStart.Activate
wSheetStart.AutoFilterMode = False

For d = DateSerial(Year(Now - 3), Month(Now - 3), Day(Now - 3)) To DateSerial(Year(Now + 3), Month(Now + 3), Day(Now + 3))
ActiveSheet.Range("A6:AC6").AutoFilter Field:=1, Criteria1:=">=" & d, Operator:=xlAnd, Criteria2:="<=" & d

Set rngVisible = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
If rngVisible.Rows.Count > 1 Or rngVisible.Areas.Count > 1 Then
Worksheets("ATA").Range("A7").Select
Worksheets("ATA").Range(Selection, Selection.End(xlToRight)).Select
Worksheets("ATA").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
 Worksheets("New report").Range("A1").PasteSpecial
 Else
Worksheets("ATA").Range("A333:AC333").Select
 Selection.Copy
 Sheets("New report").Activate

 Sheets("New report").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial
End If

Next d
End Sub

想要的结果：

A3 是 Worksheets("ATA").Range("A333:AC333") 并且 A4 是过滤后的数据

标签： vbaexcel

Answer 1

根据您的描述，我认为您不需要遍历日期范围。相反，声明两个可以保存开始和结束日期的日期变量并相应地过滤数据。

此外，除非确实需要，否则避免选择范围和工作表。

如果需要，请尝试一下并进行调整。

Private Sub CommandButton13_Click()
Dim dStart As Date, dEnd As Date
Dim wSheetStart As Worksheet, wsDest As Worksheet
Dim rngVisible As Range

Application.ScreenUpdating = False

Set wSheetStart = ThisWorkbook.Sheets("ATA")

dStart = DateAdd("d", -3, Date)
dEnd = DateAdd("d", 3, Date)

On Error Resume Next
Set wsDest = Sheets("New report")

If wsDest Is Nothing Then Sheets.Add.Name = "New report"

wSheetStart.AutoFilterMode = False

With wSheetStart
    .Range("A6:AC6").AutoFilter field:=1, Criteria1:=">=" & dStart, Operator:=xlAnd, Criteria2:="<=" & dEnd
    Set rngVisible = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    If rngVisible.Rows.Count > 1 Or rngVisible.Areas.Count > 1 Then
        .Range("A7", .Range("A7").End(xlToRight).End(xlDown)).Copy wsDest.Range("A1")
    Else
        .Range("A333:AC333").Copy wsDest.Range("A" & Rows.Count).End(3)(2)
    End If
End With
wSheetStart.AutoFilterMode = False
wSheetStart.Activate
Application.ScreenUpdating = True
End Sub