Scrubbing certain criteria and Highlighting the results

[ChadBD]

Hello Community,

I have spreadsheets sent to me that need to be scrubbed for consistency before they are sent off. My knowledge of VBA code is rudimentary at best. These sheets can contain 2500+ lines of content, the amount is always different but the content needing to be outed is always consistent.

some of the things I am needing to scrub are:
- If a column contains cells in all caps (or just generally making sure if it is 'proper' format or not)
- If a column contains cells that contain special characters
- If there are any duplicates of information within the worksheet (this could mean the whole row or just comparing results in the column, like if there is a duplicate phone number)

Minimally, I need these things highlighted to have the answers stand out. In a perfect situation, having the information that matches the criteria to be relocated to the top of the worksheet.

Only restraint is that all info on a single row needs to stay with one another.

Very new to this community and reaching out to the more knowledgeable than I.
Thank you for taking the time to help with this. It is greatly appreciated!

-Chad

 

[Roderick_E]

When you say scrub, it makes me think delete but you apparently don't want to delete.

Also, do you want to fix automatically or just highlight? For example, changing everything to proper case is easy enough.

You would start with something like this... (assumes sheet1, adjust as needed) which changes each row to propercase

Option Compare Text 'ignore text case
Sub scrubber()
Dim x As Long
Dim c As Variant
Dim lastrow As Long
lastrow = Sheet1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
For x = 1 To lastrow
Sheet1.Cells(x, 1).EntireRow.Select
For Each c In Selection.CurrentRegion.Cells
c.Value = StrConv(c.Value, vbProperCase)
Next c
'ADD MORE CODE HERE TO SCRUB OTHER THINGS
Next x
End Sub

 

[ChadBD]

I apologize if I am using the wrong terminology.

When I mean scrub, I mean for it to scan over the page. I am not wanting to correct anything automatically as the information I get is to help flush out inconsistencies in our system.

The endgame of this would be to run the macro and it either highlight the cells that contain what is being searched for. Bonus would be if would also resort the rows to have the found information relocated to the top of the page.

 

[ChadBD]

If this helps:

Column B: highlight what is not in 'proper' format.
Column C: highlight if it contains special characters (anything not alphanumeric)
Columns B, C, I, J: highlight duplicates (maybe resort to have duplicates appear together)

 

[Roderick_E]

It is considered a duplicate if it is in column B more than once (and C and I...) or does it need to be B, C, I, and J contiguously?

 

[ChadBD]

It is considered a duplicate if it is in column B more than once (and C and I...) or does it need to be B, C, I, and J contiguously?

I would say your 1st answer. Sometimes column B can have duplicates and it be ok, column C, I and J should never have duplicates.

 

[Roderick_E]

ok working on it.... brb

 

[Roderick_E]

Ok, right click on the tab to be cleaned and VIEW code and paste in this:

Function AlphaNumeric(pValue) As Boolean


   Dim LPos As Integer
   Dim LChar As String
   Dim LValid_Values As String


   'Start at first character in pValue
   LPos = 1


   'Set up values that are considered to be alphanumeric
   LValid_Values = " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ+-.0123456789"


   'Test each character in pValue
   While LPos <= Len(pValue)


      'Single character in pValue
      LChar = Mid(pValue, LPos, 1)


      'If character is not alphanumeric, return FALSE
      If InStr(LValid_Values, LChar) = 0 Then
         AlphaNumeric = False
         Exit Function
      End If


      'Increment counter
      LPos = LPos + 1


   Wend


   'Value is alphanumeric, return TRUE
   AlphaNumeric = True


End Function
Sub scrubber()
Dim x As Long
Dim lastrow As Long
lastrow = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
For x = 1 To lastrow
'check col B for propercase
If Cells(x, "b") <> Application.Proper(Cells(x, "b")) Then
Cells(x, "b").Interior.Color = vbRed
Cells(x, "z") = "x"
End If
'check col C for non-alpha numeric
If Trim(Cells(x, "c")) <> "" Then
If AlphaNumeric(Cells(x, "c")) = False Then
Cells(x, "c").Interior.Color = vbRed
Cells(x, "z") = "x"
End If
'check col C for duplicates
If Application.CountIf(Range("C:C"), Cells(x, "c")) > 1 Then
Cells(x, "c").Interior.Color = vbRed
Cells(x, "z") = "x"
End If
End If


'check col I for duplicates
If Trim(Cells(x, "i")) <> "" Then
If Application.CountIf(Range("I:I"), Cells(x, "i")) > 1 Then
Cells(x, "i").Interior.Color = vbRed
Cells(x, "z") = "x"
End If
End If
'check col J for duplicates
If Trim(Cells(x, "j")) <> "" Then
If Application.CountIf(Range("J:J"), Cells(x, "j")) > 1 Then
Cells(x, "j").Interior.Color = vbRed
Cells(x, "z") = "x"
End If
End If




Next x
End Sub

 

[Roderick_E]

run the scrubber code, the function helps the code and should only be ran from the scrubber macro

 

[Roderick_E]

whoops, the code also places an X in column Z for each line that needs cleaned, this way you can easily filter and potential for moving those rows