【发布时间】：2021-07-01 08:02:54
【问题描述】：
我一直在研究我的团队在工作中使用的预订表的功能 - 以创建供应商的预订摘要。我已经完成了大部分工作，UserForm 和InputBox 工作完美，但是一旦我将autofilter 添加到表对象的范围内，它只会按Criteria1:="01/04/2021" 之类的完全匹配过滤。尝试使用 greater than 时，它根本不应用过滤器。我做了一些挖掘，发现这可能是到期日期实际上是字符串格式而不是原始日期，我不确定我该如何解决这个问题。
我试图四处走动，将自动过滤器添加到从模板创建的就绪摘要中，但是每次它都会在一秒钟前运行的代码中引发奇怪的错误，例如 object variable or with block not set 或 for loop not initialised -唯一添加的行就在CreateSummary sub 的结尾之前：
Template.Sheets(1).ListObjects(1).Range.AutoFilter Filed:=3, Criteria1:=">01/04/2021"
整个代码如下：
Sub CreateSummary()
' start new debugging log
Debug.Print (vbCrLf & TimeStamp() & ": " & "--- Start" & vbCrLf & vbCrLf)
' declare vars
Dim SearchTerm As String
Dim SearchDate As Date
Dim Template As Workbook
Dim Tracker As Workbook
Dim WS As Worksheet
Dim i As Long
Dim Found As Integer
Dim Today As Date
Today = Date
Dim CurrentRowCount As Long
Dim LastRowCount As Long
Dim FirstEmpty As Long
' set defaults
Set Tracker = Application.ThisWorkbook
SearchDate = Date
Summary.ClickedAll = Null
i = 1
Found = 0
LastRowCount = 0
' handle user input
SearchTerm = InputBox("Please type name of the supplier (it can be just a partial e.g. 'moln' for Molnlycke")
If SearchTerm = vbNullString Then
Exit Sub
ElseIf Len(SearchTerm) < 2 Then
MsgBox ("The search term have to be minimum 2 characters." & vbCrLf & vbCrLf & "Please run macro again.")
Exit Sub
End If
SummaryOptions.Show
' Open template file and clear its contents
Set Template = Workbooks.Open("C:\Users\RJamborski\Desktop\Summary Template.xlsx")
Set TemplateTable = Template.Sheets(1).ListObjects(1)
TemplateTable.DataBodyRange.ClearContents
' loop over all worksheets to find all booking sheets
For Each WS In Tracker.Worksheets
If WS.Visible And Not WS.Name = "Matrix" Then ' if worksheet is not visible and not a Matrix
If InStr(1, WS.Name, "Template", vbTextCompare) = 0 Then ' if worksheet is not a template
Debug.Print (vbCrLf & TimeStamp() & ": " & "-- Iteration #" & i)
WS.Activate
Set WSTable = WS.ListObjects(1)
' check if filter is on and clear it
Call ClearFilters(WS)
' apply filters
' filter by search term in 'supplier' column
WSTable.Range.AutoFilter Field:=7, Criteria1:="=*" & SearchTerm & "*", Operator:=xlAnd
' if option 'All Bookings' has been clicked apply more criteria (filter out cancelled & past bookings)
If Summary.ClickedAll = False Then
With WSTable.Range
.AutoFilter Field:=7, Criteria1:="=*" & SearchTerm & "*"
.AutoFilter Field:=2, Criteria1:="=ECOM", Operator:=xlOr, Criteria2:="=Planned"
' NEED FIX: on working with string dates
.AutoFilter Field:=3, Criteria1:=">" & CDate(4 / 4 / 2021), Operator:=xlAnd
End With
End If
' check if DataBodyRange (table's content object) has any height / content found
On Error GoTo NoCellsFound
If WSTable.DataBodyRange.Height > 0 Then
Debug.Print (TimeStamp() & ": " & "Data found in " & WS.Name)
' set first empty cell reference
If Found = 0 Then
FirstEmpty = 2
ElseIf Found > 0 Then
' fix when there is only one record in template
If LastRowCount > 10000 Then
FirstEmpty = 2
Else
FirstEmpty = LastRowCount + 1
End If
End If
Debug.Print (TimeStamp() & ": " & "First Empty = " & FirstEmpty)
Found = Found + 1
' select and copy all visble/filtered data
WSTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Template.Sheets(1).Activate
Template.Sheets(1).Range("A" & FirstEmpty).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' fill in S column with WS.Name value & weekday text value formula in column A
CurrentRowCount = GetTotalRows(Template.Sheets(1))
Debug.Print (TimeStamp() & ": " & "Current Row Count = " & CurrentRowCount)
Debug.Print (TimeStamp() & ": " & "Last Row Count = " & LastRowCount)
Debug.Print (TimeStamp() & ": " & "Loop rows " & FirstEmpty & " to " & CurrentRowCount)
For n = FirstEmpty To CurrentRowCount
Template.Sheets(1).Range("S" & n).Value = WS.Name
Template.Sheets(1).Range("A" & n).Formula = "=TEXT(C" & n & ", ""dddd"")"
Next n
' update last row count after filling required cells
LastRowCount = GetTotalRows(Template.Sheets(1))
End If ' if DataBodyRange.height > 0
NoCellsFound: ' if no data found in filtered view
' update iterator
i = i + 1
' clear filters
Call ClearFilters(WS)
End If
End If
Next WS
' once complete show top of the template file to the user / reset defaults
Template.Activate
ActiveWindow.ScrollRow = 1
Range("G2").Select
' for some reason this line breaks the whole loop / WS loop reference looses pointer?
Template.Sheets(1).ListObjects(1).Range.AutoFilter Filed:=3, Criteria1:=">01/04/2021"
Debug.Print (TimeStamp() & ": " & "End Sub: Found " & LastRowCount - 1 & " records in " & Found & " sites.")
End Sub
Function GetTotalRows(Worksheet)
Set DBR = Worksheet.ListObjects(1).DataBodyRange
If DBR.Cells(1, "B").End(xlDown).Row > 10000 Then
GetTotalRows = 2
Else
GetTotalRows = DBR.Cells(1, "B").End(xlDown).Row
End If
End Function
Function ClearFilters(ByRef Worksheet As Worksheet)
Worksheet.Activate
Range("A1").Select
On Error Resume Next
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Then
ActiveSheet.ShowAllData
End If
On Error Resume Next
If ActiveSheet.AutoFilterMode Then
ActiveSheet.ShowAllData
End If
On Error Resume Next
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End Function
这里有很多 Debug.Print 调用，因为我一直试图了解宏运行的每一步到底发生了什么。
如果有人知道我该如何解决这个问题，我将不胜感激。几天来我一直在努力克服这个问题。
谢谢！
【问题讨论】：
标签： excel vba date autofilter