VBA Code to optimize and clean data

Hello JoaoVr ,

Welcome to the Forum!

I have attached an example workbook with the macro shown here. The macro is run from a button added to the worksheet. The only column that has special formatting is column "E" which has been formatted as text to allow for the leading zero or zeroes in the Code number.

The following checks are made. The Email address must contain at least 1 character in the domain part , an at sign ("@") separator, 1 character in the followed by at least 1 period followed at least 1 character in the local part. Also, no spaces are allowed in the Email address. The macro is not designed to check for a valid email address according to RFC syntax rules.

Some adjustments may be needed to adapt the code to your workbook. If you have any problems, let me know.

' Thread:  http://www.excelforum.com/excel-programming/820537-vba-code-to-optimize-and-clean-some-unwanted-data.html
' Poster:  JoaoVr
' Written: March 20, 2012
' Author:  Leith Ross

Sub CheckData()

    Dim Code As Variant
    Dim Data As Variant
    Dim Email As String
    Dim I As Long
    Dim Matches As Collection
    Dim Phone As Variant
    Dim Rng As Range
    Dim Text As String
    Dim Wks As Worksheet
    
        Set Wks = Worksheets("Sheet1")
        
            Set Rng = Wks.Range("A1").CurrentRegion.Offset(1, 0)
            Set Rng = Rng.Resize(RowSize:=Rng.Rows.Count - 1)
             
            Data = Rng.Value
            
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            
              ' Check Email, Phone, and Code
                For I = 1 To UBound(Data, 1)
                    Email = Data(I, 3)
                        If (Not Email Like "?*@*?.*?") Or InStr(1, Email, " ") Then
                            Rng.Item(I, 3).Font.Color = vbGreen
                            Rng.Item(I, 7) = "X"
                        End If
                    Phone = CStr(Data(I, 4))    ' 9 digits
                        If Not Phone Like "#########" Then
                            Rng.Item(I, 4).Font.Color = vbGreen
                            Rng.Item(I, 7) = "X"
                        End If
                    Code = Data(I, 5)           ' 3 Digits
                        If Not Code Like "###" Then
                            Rng.Item(I, 5).Font.Color = vbGreen
                            Rng.Item(I, 7) = "X"
                        End If
                Next I
                
                Set Matches = New Collection
              
              ' Check for Duplicate rows with no problems
                For I = 1 To UBound(Data, 1)
                    If Rng.Item(I, 7) <> "X" Then
                        Text = Trim(LCase(Data(I, 1) & Data(I, 2) & Data(I, 3) & Data(I, 4) & Data(I, 5)))
                        On Error Resume Next
                            Matches.Add I, Text
                            If Err <> 0 Then
                                Rng.Rows(I).Font.Color = vbRed
                                Rng.Rows(Matches(Text)).Font.Color = vbRed
                                Rng.Item(I, 7) = "X"
                            End If
                        On Error GoTo 0
                    End If
                Next I
                
            Application.Calculation = xlCalculationAutomatic
            Application.ScreenUpdating = True
            
End Sub

[code]