Sub Validation_Click()
Dim ws As Worksheet, rpt As Worksheet, cel As Range
Dim lastR As Long, lastC As Long, r As Long, c As Long
Dim ConvertDate As String
Dim NumInt As Integer
Dim NumDec As Integer
Dim PosofDecPoint As Integer
Dim eChar As Integer
Dim ErrCount As Integer
Set ws = ActiveSheet
'get last column
lastC = ws.Cells(5, ws.Columns.Count).End(xlToLeft).Column
'get last row used in any column
For c = 2 To lastC
lastR = WorksheetFunction.Max(lastR, ws.Cells(ws.Rows.Count, c).End(xlUp).Row)
Next c
'insert results sheet
Application.ScreenUpdating = False
Set rpt = Sheets.Add
rpt.Cells(2, 1) = "Cells"
rpt.Cells(2, 2) = "Remarks"
'loop values in cells and write to results sheet
For c = 3 To lastC
For r = 10 To lastR
Set cel = ws.Cells(r, c)
'Check if zz field contains number
If ws.Cells(5, c) Like "*zz*" Then
For eChar = 1 To Len(cel)
If cel <> "" And IsNumeric(Mid(cel, eChar, 1)) = True Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "zz field should not contain numeric numbers!"
eChar = Len(cel)
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
Next eChar
End If
'Check if xx or yy is numeric
If ws.Cells(5, c) Like "*xx*" Or ws.Cells(5, c) Like "*yy*" Then
NumInt = Mid(ws.Cells(8, c), InStr(1, ws.Cells(8, c), "(", vbBinaryCompare) + 1, InStr(1, ws.Cells(8, c), ")", vbBinaryCompare) - (InStr(1, ws.Cells(8, c), "(", vbBinaryCompare) + 1))
If cel <> "" And IsNumeric(cel) = False Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "field should not contain text!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
If (Len(cel) > NumInt) Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "Number of character exceed defined length!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
End If
'Check if fields is numeric
If ws.Cells(5, c) Like "*GG*" Then
If cel <> "" And IsNumeric(cel) = False Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "field should not contain text!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
If (Len(cel) <> 9 And cel <> "" And IsNumeric(cel) = True) Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "GG account should be 9 digit!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
End If
'Check for date format and validity
If ws.Cells(8, c) Like "*Date*" Then
ConvertDate = Mid(cel, 5, 2) & "/" & Right(cel, 2) & "/" & Left(cel, 4)
If (Len(cel) = 8) Then
If (cel <> "" And IsDate(ConvertDate) = False) Or (cel <> "" And Mid(cel, 5, 2) > 12) Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "Invalid Date, Format should be YYYYMMDD!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
End If
If ((Len(cel) <> 8) And cel <> "") Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "Invalid Date, Format should be YYYYMMDD!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
End If
'Check for Numeric fields and length
If ws.Cells(8, c) Like "*Numeric*" Then
PosofDecPoint = InStr(1, (cel), ".", vbBinaryCompare)
NumInt = Mid(ws.Cells(8, c), InStr(1, ws.Cells(8, c), "(", vbBinaryCompare) + 1, InStr(1, ws.Cells(8, c), ",", vbBinaryCompare) - (InStr(1, ws.Cells(8, c), "(", vbBinaryCompare) + 1))
NumDec = Mid(ws.Cells(8, c), InStr(1, ws.Cells(8, c), ",", vbBinaryCompare) + 1, InStr(1, ws.Cells(8, c), ")", vbBinaryCompare) - (InStr(1, ws.Cells(8, c), ",", vbBinaryCompare) + 1))
If cel <> "" And IsNumeric(cel) = False Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "Field should contain number only!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
If (PosofDecPoint > 0 And NumInt < PosofDecPoint - 1) Or (PosofDecPoint > 0 And NumDec < Len(cel) - PosofDecPoint) Or (PosofDecPoint = 0 And NumInt < Len(cel)) Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "Number of character exceed defined length number!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
End If
'Check for length of Char and Nvarchar data type
If ws.Cells(8, c) Like "*Char*" Or ws.Cells(8, c) Like "*char*" Then
NumInt = Mid(ws.Cells(8, c), InStr(1, ws.Cells(8, c), "(", vbBinaryCompare) + 1, InStr(1, ws.Cells(8, c), ")", vbBinaryCompare) - (InStr(1, ws.Cells(8, c), "(", vbBinaryCompare) + 1))
If cel <> "" And Len(cel) > NumInt Then
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "Number of character exceed defined length!"
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
End If
If ws.Cells(7, c) Like "*Mandatory*" And Len(ws.Cells(7, c)) < 50 Then
If cel = "" Then
rpt.Cells(rpt.Rows.Count, 2).End(xlUp).Offset(1) = "Mandatory Cells Needs To Be Filled Up!"
rpt.Cells(rpt.Rows.Count, 1).End(xlUp).Offset(1) = cel.Address(0, 0)
ErrCount = ErrCount + 1
cel.Font.Color = RGB(255, 0, 0)
End If
End If
If ErrCount = 0 Then
cel.Font.Color = RGB(0, 0, 0)
Else
ErrCount = 0
End If
Next r
Next c
End Sub