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]
LinkBack URL
About LinkBacks
VBA Code to optimize and clean data
Register To Reply
below the post.
Bookmarks