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

Question

I want to use the VBA to filter the data according to the criteria: Date -3 to Date +3 and then copy to the new worksheet. If no result return, it also copy the blank to the new worksheet, but not success that only copy the today's data to the new worksheet, please tell me how to resolve this? Thank you very much.

Here is my code:

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

Wanted result:

A3 is the Worksheets("ATA").Range("A333:AC333") and A4 is the filtered data

Answer 1

As per your description, I don't think that you need to loop through date range. Instead, declare two date variables which may hold the start and end dates and filter the data accordingly.

Also, avoid selecting ranges and sheets unless really required.

Please give this a try and tweak it if required.

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