Finding cells that do not match a predefined specific pattern in Excel using VBA-CodePudding

Am trying to make a VBA validation sheet on Excel to find all the cells that do not match a predefined pattern and copy it to another sheet

My pattern is "4 numbers/5 numbers" Ex: 1234/12345 is accepted 2062/67943 is accepted 372/13333 is not accepted 1234/1234 is not accepted etc...

I tried to put the following in the conditions sheet : <>****/***** and <>????/????? and both did not work (am not sure about the correctness of the approach as am still a beginner in VBA)

For the code itself, this is what I wrote :

Sub GuaranteeElig()

Sheets.Add After:=ActiveSheet

ActiveSheet.Name = SheetName

Sheets("MainSheet").UsedRange.AdvancedFilter Action:= _
xlFilterCopy, 
CriteriaRange:=Sheets("ConditionsSheet").Range("B1:B2"), _
CopyToRange:=Range("A1"), Unique:=False
End Sub

Any tips on how I can do it ?

Thanks in advance :)

CodePudding user response：

As long as the values of the numbers are independent and do not matter, and it is only the Length of the numerical strings that count, you could use a for loop on the cells from the "search" sheet (I assume this is the MainSheet as shown in your code?) where your values are contained.

From there, I'll give you a couple ways to place the data in the validation sheet (assuming this is your ConditionsSheet as shown in your code?) where you are trying to pinpoint the values.

(You may need to change part of your approach depending on how you want the incorrect set of values laid out on your secondary sheet - but this should get you started.) I added a TON of comments as you say you're new to VBA - these will help you understand what is being done.

Sub GuaranteeElig()

'Adding this to help with performance:
Application.ScreenUpdating = False

'Assuming you are adding a sheet here to work with your found criteria.
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ConditionsSheet"

'Using the naming bits below I am assuming the data you are searching for is on MainSheet

'Get used range (most accurate and efficient way I have found yet, others on S.O.
'may have better ways for this - research it if this does not work for you)
'I have had problems using the Sheets().UsedRange method.

Dim c as Long 'This may not be necessary for you if you are looping through only column "A"
Dim r as Long

'Cells(y,x) method uses numerical values for each row (y) or column (x).

c = Cells(1, Columns.Count).End(xlToLeft).Column 'May not be necessary depending on your needs.
                                                 'Using this because you have "UsedRange" in your 
                                                 'code.
'.End(xlToLeft) signifies we are going to the end of the available cell range of
'Row 1 and then performing a "Ctrl Left Arrow" to skip all blank cells until we hit
'the first non-blank cell.

r = Cells(Rows.Count, 1).End(xlUp).Row
'.End(xlUp) method is similar - we go to the end of the available cell range for the
'column ("A" in this case), then performing a "Ctrl Up Arrow" to skip all blank cells.

'If you have a header row which spans across the sheet, this is your best option,
'unless you have 'helper' cells which extend beyond the final column of this header
'row.  I am assuming Row 1 is a header in this case - change to your needs.
'For your Rows - choose the column which contains congruent data to the bottom of
'your used range - I will assume column 1 in this case - change to suit your needs.


Dim i as long
Dim j as integer
Dim cel as Range
Dim working_Str() as String 'String Array to use later
Dim string1 as String
Dim string2 as String
Dim badString as Boolean

For i = 2 to r Step 1 'Step down from row 2 to the end of data 1 Row at a time
                      'Row 1 is header.

  set cel=Cells(i, 1) 'Sets the cell to check - assuming data is in Column "A"
                      'i will change from for loop so 'cel' changes from "A2555"
                      'to "A2554" to "A2553" etc.
  
  working_Str=Split(cel.Value, "/", -1) 'Splits the value based on "/" inside of cel

  string1=working_Str(0) 'what we hope will always be 4 digits
  string2=working_Str(1) 'what we hope will always be 5 digits
  
  If Len(string1)<>4 Then 'string1 _(xxxx)_(/)(don't care) does not equal 4 digits in length
    
    badString = True
    
  Elseif Len(string2)<>5 Then ''string1 (don't care)(/)_(xxxxx)_ does not equal 5 digits in length
    
    badString = True
    
  End If
  
  If badString Then 'If either strings above were not correct length, then
    'We will copy cell value over to the new sheet "ConditionsSheet"
    
    'Comment the next 2 commands to change from going to one row at a time to
    'Matching same row/Cell on the 2nd sheet.  Change to suit your needs.
    j = j   1 'Counter to move through the cells as you go, only moving one cell
              'at a time as you find incorrect values.
    Sheets("ConditionsSheet").Range("A" & j).Value=cel.Value 'sets the value on other sheet

    'UNComment the next command to change from going to one row at a time to
    'matching same row/cell on the 2nd sheet.  Change to suit your needs.
    
    'Sheets("ConditionsSheet").Range("A" & i).Value=cel.Value
  End if
  
  badString = False 'resets your boolean so it will not fail next check if strings are correct
  
Next i

'Returning ScreenUpdating back to True to prevent Excel from suppressing screen updates
Application.ScreenUpdating = True

End Sub

UPDATE

Check the beginning and ending lines I just added into the subroutine. Application.ScreenUpdating will suppress or show the changes as they happen - suppressing them makes it go MUCH quicker. You also do not want to leave this setting disabled, as it will prevent Excel from showing updates as you try to work in the cell (like editing cell values, scrolling etc. . . Learned the hard way. . .)

Also, if you have a lot of records in the given row, you could try putting the data into an array first. There is a great example here at this StackOverflow Article.

Accessing the values of a range across multiple rows takes a LOT of bandwidth, so porting the range into an Array first will make this go much quicker, but it still may take a bit. Additionally, how you access the array information will be a little different, but it'll make sense as you research it a little more.

Alternative To VBA

If you want to try using a formula instead, you can use this - just modify for the range you are looking to search. This will potentially take longer depending on processing speed. I am entering the formula on 'Sheet2' and accessing 'Sheet1'

=IF(COUNTIF(Sheet1!A1,"????/?????"),1,0)

You are spot on with the search pattern you want to use, you just need to use a function which uses wildcard characters within an "if" function. What you do with the "If value is true" vs "If value is false" bits are up to you. COUNTIF will parse wildcards, so if it is able to "count" the cell matching this string combination, it will result in a "True" value for your if statement.

CodePudding user response：

Regex method, this will dump the mismatched value in a worksheet named Result, change the input range and worksheet name accordingly.

In my testing, 72k cells in UsedRange takes about 4seconds~:

Option Explicit

Sub GuaranteeElig()
    Const outputSheetName As String = "Result"
    
    Dim testValues As Variant
    testValues = ThisWorkbook.Worksheets("MainSheet").UsedRange.Value 'Input Range, change accordingly
            
    Const numPattern As String = "[\d]{4}\/[\d]{5}"
    Dim regex As Object
    Set regex = CreateObject("VBScript.Regexp")
    regex.Pattern = numPattern
    
    Dim i As Long
    Dim n As Long
    Dim failValues As Collection
    Set failValues = New Collection
    
    'Loop through all the values and test if it fits the regex pattern - 4 digits   /   5 digits
    'Add the value to failValues collection if it fails the test.
    For i = LBound(testValues, 1) To UBound(testValues, 1)
        For n = LBound(testValues, 2) To UBound(testValues, 2)
            If Not regex.Test(testValues(i, n)) Then failValues.Add testValues(i, n)
        Next n
    Next i
    
    Erase testValues
    Set regex = Nothing
    
    If failValues.Count <> 0 Then
        'If there are mismatched value(s) found
        
        'Tranfer the values to an array for easy output later
        Dim outputArr() As String
        ReDim outputArr(1 To failValues.Count, 1 To 1) As String
        For i = 1 To failValues.Count
            outputArr(i, 1) = failValues(i)
        Next i
        
        'Test if output worksheet exist
        Dim outputWS As Worksheet
        On Error Resume Next
        Set outputWS = ThisWorkbook.Worksheets(outputSheetName)
        On Error GoTo 0
        
        'If output worksheet doesn't exist, create a new sheet else clear the first column for array dump
        If outputWS Is Nothing Then
            Set outputWS = ThisWorkbook.Worksheets.Add
            outputWS.Name = outputSheetName
        Else
            outputWS.Columns(1).Clear
        End If
    
        'Dump the array starting from cell A1
        outputWS.Cells(1, 1).Resize(UBound(outputArr, 1)).Value = outputArr
    Else
        MsgBox "No mismatched value found in range"
    End If
    
    Set failValues = Nothing
End Sub

If you do not need duplicate values in the list of mismatched (i.e. unique values) then sound out in the comment.