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是过滤后的数据

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