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
A3 is the Worksheets("ATA").Range("A333:AC333") and A4 is the filtered data
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.