Macro to delete rows that contain specific complexity requirements

[caracal]

I've got a long list of commonly compromised passwords I need to trim down, leaving only the more complex combinations that meet the company's policy. I want to delete any rows that do not meet at least three of these four required contents: lowercase letters, uppercase letters, numbers, symbols. If this is a little too complicated, I'd settle for just removing any lines that are nothing but lowercase letters (no capital letters, no numbers, no symbols).
So a list like this:
password1
password
Password
P@ssword
Password1

Would become:
Password1
P@ssword

Thanks

 

[Trebor76]

Hi caracal,

Welcome to MrExcel!!

Try this (initially on a copy of your data as the results cannot be undone if they are not as expected):

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    Dim rngCell As Range, rngDelete As Range
    Dim intCount As Integer
   
    Application.ScreenUpdating = False
   
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name with the list of passwords. Change to suit.
    For Each rngCell In ws.Range("A2:A" & ws.Range("A" & Rows.Count).End(xlUp).Row)  '<-Runs on the from cell A2 on the 'ws' sheet. Change to suit.
        'Increment the 'intCount' variable if...
        '1. There's a lower case letter in the string
        If RegEx("[a-z]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        '2. There's an upper case letter in the string
        If RegEx("[A-Z]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        '3. There's a number in the string
        If RegEx("[0-9]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        '4. 'There's a special character in the string (Note 'Special" here is considered to be anything not a letter or number).
         If RegEx("[^A-Za-z0-9]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        'If only two or less of the password criteria are meet, then...
        If intCount <= 2 Then
            '...add the cell to the 'rngDelete' variable
            If rngDelete Is Nothing Then
                Set rngDelete = rngCell
            Else
                Set rngDelete = Union(rngDelete, rngCell)
            End If
        End If
        intCount = 0
    Next rngCell
   
    'If the 'rngDelete' variable has been populayed, then...
    If Not rngDelete Is Nothing Then
        '...delete its row(s)
        rngDelete.EntireRow.Delete
    End If
   
    Application.ScreenUpdating = True

End Sub
Function RegEx(Pattern As String, TextToSearch As String) As Boolean 'https://stackoverflow.com/questions/4556910/how-do-i-get-regex-support-in-excel-via-a-function-or-custom-function
   
    Dim objRE As Object, objREMatches As Object

    Set objRE = CreateObject("vbscript.regexp")
    With objRE
        .MultiLine = False
        .Global = False
        .IgnoreCase = False
        .Pattern = Pattern
    End With

    Set objREMatches = objRE.Execute(TextToSearch)
    If objREMatches.Count > 0 Then
        RegEx = True
    Else
        RegEx = False
    End If
   
End Function

Regards,

Robert

 

[Akuini]

I want to delete any rows that do not meet at least three of these four required contents: lowercase letters, uppercase letters, numbers, symbols.

Try this:
Passwords that satisfy the requirements will be marked as 1, if not, then 0.
Note: A space is considered as symbol.

Sub caracal_1()
Dim regEx As Object
Dim i As Long, j As Long, k As Long, h As Long
Dim x As String
Dim va, vc, ary, pt
Dim Flag As Boolean
Dim d As Object

va = Range("A1", Cells(Rows.Count, "A").End(xlUp))
ReDim vc(1 To UBound(va, 1), 1 To 1)
Set d = CreateObject("scripting.dictionary")
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
    ary = Split("|a-z|A-Z|0-9", "|")
    h = UBound(ary)

    For i = 1 To UBound(va, 1)
            For j = 1 To Len(va(i, 1))
                Flag = False
                x = Mid(va(i, 1), j, 1)
                    For k = 1 To h
                        .Pattern = "[" & ary(k) & "]"
                        If .test(x) Then
                            d(k) = ""
                            Flag = True: Exit For
                        End If
                    Next
                If Flag = False Then d(4) = ""
            Next

                If d.Count < 3 Then
                   vc(i, 1) = 0
                Else
                   vc(i, 1) = 1
                End If
           d.RemoveAll
    Next
End With
Range("B1").Resize(UBound(vc, 1), 1) = vc
End Sub

Example:

caracal_1.xlsm
	A	B
1	password1	0
2	password	0
3	Password	0
4	P@ssword	1
5	Password1	1
6	sfdS df	1
7	wgager #	0
Sheet1

 

[Fuji]

UDF

Use in cell like
=ValidPW(A1:A6)

Function ValidPW(r As Range)
    Dim a, ptn, i&, ii&, n&, p&, x
    a = r.Resize(, 2).Value
    ReDim x(1 To UBound(a, 1))
    ptn = Array("[A-Z]", "[a-z]", "\d", "[^A-Za-z\d ]")
    With CreateObject("VBScript.RegExp")
        For i = 1 To UBound(a, 1)
            p = 0
            For ii = 0 To UBound(ptn)
                .Pattern = "(?=^.*" & ptn(ii) & ".*$)"
                If .test(a(i, 1)) Then p = p + 1
                If p < ii Then Exit For
            Next
            If p > 2 Then n = n + 1: x(n) = a(i, 1)
        Next
    End With
    If n Then
        ReDim Preserve x(1 To n)
        ValidPW = Application.Transpose(x)
    End If
End Function

 

[Fuji]

I want to delete any rows that do not meet at least three of these four required contents:

Missed this.
Assuming the data in col.A and A1 houses Header, so the data starts from A2 down.

Sub test()
    Dim r As Range
    Application.ScreenUpdating = False
    With Range("a1", Range("a" & Rows.Count).End(xlUp))
        If .Parent.FilterMode Then .Parent.ShowAllData
        Set r = .Offset(, .Columns.Count + 1).Range("a1:a2")
        r(2).Formula2 = "=iserror(match(true,exact(a2,validpw(" & .Address & ")),0))"
        .AdvancedFilter 1, r
        .Offset(1).SpecialCells(12).Delete xlShiftUp
        If .Parent.FilterMode Then .Parent.ShowAllData
        r(2) = ""
    End With
    Application.ScreenUpdating = True
End Sub

Function ValidPW(r As Range)
    Dim a, ptn, i&, ii&, n&, p&, x
    a = r.Resize(, 2).Value
    ReDim x(1 To UBound(a, 1))
    ptn = Array("[A-Z]", "[a-z]", "\d", "[^A-Za-z\d ]")
    With CreateObject("VBScript.RegExp")
        For i = 1 To UBound(a, 1)
            p = 0
            For ii = 0 To UBound(ptn)
                .Pattern = "(?=" & ptn(ii) & ")"
                If .test(a(i, 1)) Then p = p + 1
                If p < ii Then Exit For
            Next
            If p > 2 Then n = n + 1: x(n) = a(i, 1)
        Next
    End With
    If n Then
        ReDim Preserve x(1 To n)
        ValidPW = Application.Transpose(x)
    End If
End Function

 

[caracal]

Hi caracal,

Welcome to MrExcel!!

Try this (initially on a copy of your data as the results cannot be undone if they are not as expected):

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    Dim rngCell As Range, rngDelete As Range
    Dim intCount As Integer
  
    Application.ScreenUpdating = False
  
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name with the list of passwords. Change to suit.
    For Each rngCell In ws.Range("A2:A" & ws.Range("A" & Rows.Count).End(xlUp).Row)  '<-Runs on the from cell A2 on the 'ws' sheet. Change to suit.
        'Increment the 'intCount' variable if...
        '1. There's a lower case letter in the string
        If RegEx("[a-z]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        '2. There's an upper case letter in the string
        If RegEx("[A-Z]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        '3. There's a number in the string
        If RegEx("[0-9]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        '4. 'There's a special character in the string (Note 'Special" here is considered to be anything not a letter or number).
         If RegEx("[^A-Za-z0-9]", CStr(rngCell)) = True Then
            intCount = intCount + 1
        End If
        'If only two or less of the password criteria are meet, then...
        If intCount <= 2 Then
            '...add the cell to the 'rngDelete' variable
            If rngDelete Is Nothing Then
                Set rngDelete = rngCell
            Else
                Set rngDelete = Union(rngDelete, rngCell)
            End If
        End If
        intCount = 0
    Next rngCell
  
    'If the 'rngDelete' variable has been populayed, then...
    If Not rngDelete Is Nothing Then
        '...delete its row(s)
        rngDelete.EntireRow.Delete
    End If
  
    Application.ScreenUpdating = True

End Sub
Function RegEx(Pattern As String, TextToSearch As String) As Boolean 'https://stackoverflow.com/questions/4556910/how-do-i-get-regex-support-in-excel-via-a-function-or-custom-function
  
    Dim objRE As Object, objREMatches As Object

    Set objRE = CreateObject("vbscript.regexp")
    With objRE
        .MultiLine = False
        .Global = False
        .IgnoreCase = False
        .Pattern = Pattern
    End With

    Set objREMatches = objRE.Execute(TextToSearch)
    If objREMatches.Count > 0 Then
        RegEx = True
    Else
        RegEx = False
    End If
  
End Function

Regards,

Robert

This worked perfectly.
Thanks to everyone that contributed their time and effort to a solution!