Eric Penfold
Active Member
- Joined
- Nov 19, 2021
- Messages
- 431
- Office Version
- 365
- Platform
- Windows
- Mobile
Trying to filter between dates but this code seems to filter out blanks rather than dates in Col A2 to lastrow.
VBA Code:
Sub BOReason()
Dim Ws As Worksheet
Dim LRow As Long, myRow As Long
Dim x As Variant, y As Variant, i As Variant
Dim Rng As Range, Comparerng As Range
Dim YDat As Date
Dim TDat As Date
Dim NDat As Date
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set Ws = ActiveSheet
LRow = Ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
YDat = Format(CDate(Application.WorksheetFunction.WorkDay(Date, -1)), "dd/mm/yyyy")
TDat = Format(Date, "dd/mm/yyyy")
NDat = Format(Date + 1, "dd/mm/yyyy")
On Error Resume Next
With Ws
Set Rng = .Range("A2:A" & LRow).Find(YDat, LookIn:=xlValues, LookAt:=xlWhole)
myRow = ActiveCell.Row
With Rng
If Rng Is Nothing Then
.Range("A1").AutoFilter 1, Format(TDat, "dd/mm/yyyy"), 2, Format(NDat, "dd/mm/yyyy")
Else
.AutoFilter field:=1, _
Criteria1:=">=" & YDat, _
Operator:=xlAnd, _
Criteria2:="<=" & NDat
End If
End With
If Ws.Name <> "Summary" And Ws.Name <> "Trend" And Ws.Name <> "Supplier BO" And Ws.Name <> "Dif Depot" Then
Set Comparerng = .Range("E2:E" & LRow)
For Each x In Comparerng.SpecialCells(xlCellTypeVisible)
For Each y In Comparerng.SpecialCells(xlCellTypeVisible)
If (x = y) And (x.Row <> y.Row) Then
If .Range("A" & y.Row) <> "" Then
.Range("J" & y.Row) = .Range("J" & myRow)
End If
End If
Next y
Next x
End If
.Range("AA1") = ""
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Ws.ShowAllData
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub