I have example data here that I need to filter a column, do a check of another column and then based on that check it'll decide to delete rows or not.
Example: filter Customer Number column for 1035 and then check if Months Pay has any values between 0-4, if yes then delete all rows of 1035. If no then check Own column, if it has any values between 1-5 then delete all rows of 1035.
And I need this to keep looping for all non-blank Customer Number.
Is this possible to create?
Option Explicit
Sub FilterCheckDeleteUniques()
Application.ScreenUpdating = False
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the table range ('rg') (has headers).
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
' Reference the data range ('drg') (no headers).
Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
' Write the data for the 3rd and 4th columns to an array.
' (Column, Greater Than or Equal, Less Than or Equal)
Dim InRangeArr() As Variant
InRangeArr = Array(VBA.Array(3, 0, 4), VBA.Array(4, 1, 5))
' Write the values from the 2nd column to an array ('Data').
Dim Data As Variant: Data = GetRange(drg.Columns(2))
' Write the unique values from the array to the 'keys'
' of a dictionary ('dict').
Dim dict As Object: Set dict = DictColumn(Data)
Erase Data
' Declare additional variables.
Dim frg As Range
Dim cfrg As Range
Dim iKey As Variant
' Loop through the 'keys' of the dictionary.
For Each iKey In dict.Keys
' Reference the current criteria filtered rows if conditions
' are met.
Set cfrg = RefFilteredRangeSpecial(rg, drg, CStr(iKey), InRangeArr)
' Combine the current criteria visible rows into a range.
If Not cfrg Is Nothing Then
If frg Is Nothing Then
Set frg = cfrg
Else
Set frg = Union(frg, cfrg)
End If
End If
Next iKey
' Delete all combined rows in one go.
If Not frg Is Nothing Then frg.Delete xlShiftUp
Application.ScreenUpdating = True
' Inform.
MsgBox "Operation finished.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values from a column ('ColumnIndex')
' of a 2D array ('Data') in the keys of a dictionary.
' Remarks: Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumn( _
ByVal Data As Variant, _
Optional ByVal ColumnIndex As Variant) _
As Object
Const ProcName As String = "DictColumn"
On Error GoTo ClearError
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive
Dim c As Long
If IsMissing(ColumnIndex) Then
c = LBound(Data, 2) ' use first column index
Else
c = CLng(ColumnIndex)
End If
Dim Key As Variant
Dim r As Long
For r = LBound(Data, 1) To UBound(Data, 1)
Key = Data(r, c)
If Not IsError(Key) Then ' exclude error values
If Len(CStr(Key)) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Function ' only error values and blanks
Set DictColumn = dict
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: References a filtered range if conditions are met...
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFilteredRangeSpecial( _
ByVal rg As Range, _
ByVal drg As Range, _
ByVal Criteria As String, _
InRangeArr() As Variant) _
As Range
' Reference the worksheet.
Dim ws As Worksheet: Set ws = rg.Worksheet
' Filter the table range.
rg.AutoFilter 2, Criteria
' Reference the visible data range ('vdrg'), the filtered rows.
Dim vdrg As Range: Set vdrg = drg.SpecialCells(xlCellTypeVisible)
' Remove the autofilter.
ws.AutoFilterMode = False
' Declare additional variables.
Dim irg As Range
Dim iCell As Range
Dim iValue As Variant
Dim n As Long
Dim IsInRange As Boolean
' Loop.
For n = LBound(InRangeArr) To UBound(InRangeArr)
Set irg = Intersect( _
vdrg, ws.Columns(rg.Columns(InRangeArr(n)(0)).Column))
For Each iCell In irg.Cells
iValue = iCell.Value
If VarType(iValue) = vbDouble Then ' is a number
If iValue >= InRangeArr(n)(1) _
And iValue <= InRangeArr(n)(2) Then ' in range
IsInRange = True
Exit For
'Else ' not in range; do nothing
End If
End If
Next iCell
If IsInRange Then ' in range found
Set RefFilteredRangeSpecial = vdrg
Exit For
'Else ' in range not found; do nothing
End If
Next n
End Function