by Rone (9 Submissions)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 14th May 2004
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Validates an Excel Sheet.
VBcoders
Dim Row_Validation As Boolean
Sub Validate_Form()
Dim Failed_Validation As Boolean
'Check the Global Variables for each sheet to see if they have been
'validated yet. If not, fail the form validation.
If Failed_Validation = True Then
MsgBox "Form is not set up right"
Else
'Build XML file
Build_XML
End If
End Sub
Sub Build_XML()
Dim xmldoc As MSXML2.DOMDocument
Dim xmLstring As String
Dim rowCntr As Integer
Dim colCntr As Integer
Dim fileLoc As String
Dim cmdlg As New CommonDialog
Dim strQuote As String
xmLstring = ""
rowCntr = 0
colCntr = 0
strQuote = """"
Set xmldoc = CreateObject("Microsoft.XMLDOM")
'Create Parent Node and add it to the string
xmLstring = "<FORM Name=" & strQuote & Range("Audit_Form").Value & strQuote & "> "
'-----------------------
'CATEGORIES
'-----------------------
rowCntr = 8
colCntr = 1
Do While Worksheets("Categories").Cells(rowCntr, 1).Value <> ""
'Add Item
xmLstring = xmLstring & "<CATEGORY "
For colCntr = 1 To 6 'There are only 6 columns
Select Case colCntr
Case 1 ' Category ID
xmLstring = xmLstring & "Id=" & strQuote & Worksheets("Categories").Cells(rowCntr, colCntr).Value & strQuote & " "
Case 2 ' Parent Category
xmLstring = xmLstring & "Parent=" & strQuote & Worksheets("Categories").Cells(rowCntr, colCntr).Value & strQuote & " "
Case 3 'Category Name
xmLstring = xmLstring & "Name=" & strQuote & Worksheets("Categories").Cells(rowCntr, colCntr).Value & strQuote & " "
Case 4 'View Type
xmLstring = xmLstring & "Type=" & strQuote & Worksheets("Categories").Cells(rowCntr, colCntr).Value & strQuote & " "
Case 5 ' Category Answer
xmLstring = xmLstring & "Answer=" & strQuote & Worksheets("Categories").Cells(rowCntr, colCntr).Value & strQuote & " "
Case 6 'ReAudit
xmLstring = xmLstring & "Reaudit=" & strQuote & Worksheets("Categories").Cells(rowCntr, colCntr).Value & strQuote & " "
End Select
Next
'Close the Item Tag
xmLstring = xmLstring & "></CATEGORY>"
'Move the counter to the next row
rowCntr = rowCntr + 1
Loop
'Add the closing to the Parent Node
xmLstring = xmLstring & "</FORM>"
'Load it so it can be saved
xmldoc.loadXML xmLstring
'obtain file location
cmdlg.ShowSave
fileLoc = cmdlg.Filename
'Save the file as XML
xmldoc.Save (fileLoc)
'Display successful save
ActiveSheet.Hyperlinks.Add Anchor:=Cells(10, 2), Address:=fileLoc _
, TextToDisplay:= _
"File saved successfuly at: " & fileLoc
End Sub
Sub Validate_Catetory()
Dim intBlankRow As Integer
Dim rngBlankCell As Range
Dim xxRow As Integer, yyCharPosition As Integer
Dim strCategoryValue As String
Dim strChar As String
Dim strStartRow As Integer
Dim strCategoryRange As String
Dim strCatIDCol As String
Dim strCatParentCol As String
Dim strCatNameCol As String
Dim strCatViewCol As String
Dim strCatAnswerCol As String
Dim strCatReAuditCol As String
'Unprotect the sheet first
Unprotect_Sheet "Categories"
'Initialize Variables
Cat_Failed_Validation = False
Row_Validation = False
strStartRow = 8
strCatIDCol = "A"
strCatParentCol = "B"
strCatNameCol = "C"
strCatViewCol = "D"
strCatAnswerCol = "E"
strCatReAuditCol = "F"
'Determine the last row
Set rngBlankCell = Sheets("Categories").Columns(1)
intBlankRow = rngBlankCell.Find("", Range(strCatIDCol & strStartRow)).Row
'Clear the comments
strCategoryRange = "A" & strStartRow & ":F" & intBlankRow - 1
Clear_Comments (strCategoryRange)
'Reset the Font
Reset_Font strCategoryRange
For xxRow = strStartRow To intBlankRow - 1
'-----------------------------
'Check the Category ID
'-----------------------------
strCategoryValue = Range(strCatIDCol & xxRow).Value
For yyCharPosition = 1 To Len(strCategoryValue)
strChar = Mid(strCategoryValue, yyCharPosition, 1)
Row_Validation = Check_ASCII(strChar)
If Row_Validation = True Then
Color_Text (strCatIDCol & xxRow)
Add_Comment (strCatIDCol & xxRow), "The following are a list of accepted characters: a-z,A-Z,1-9,-,_ Spaces, etc. are not allowed."
'set it for the next row
Row_Validation = False
'Set Category Failure
Cat_Failed_Validation = True
End If
Next
'-----------------------------
'Check the Category Name (Required)
'-----------------------------
'Make sure a name exists
strCategoryValue = Range(strCatNameCol & xxRow).Value
If strCategoryValue = "" Then
Color_Text (strCatNameCol & xxRow)
Add_Comment (strCatNameCol & xxRow), "The Category Name is a required field."
Cat_Failed_Validation = True
End If
'Check Length of Name (Max Characters = 20)
If Len(strCategoryValue) > 20 Then
Color_Text (strCatNameCol & xxRow)
Add_Comment (strCatNameCol & xxRow), "The length of the Category Name cannot exceed 20 characters."
Cat_Failed_Validation = True
End If
'-----------------------------
'Check the View Type (Required)
'-----------------------------
strCategoryValue = UCase(Range(strCatViewCol & xxRow).Value)
Select Case strCategoryValue
Case ""
Color_Text (strCatViewCol & xxRow)
Add_Comment (strCatViewCol & xxRow), "The View Type is a required field."
Cat_Failed_Validation = True
Case "CATEGORY LIST"
'No need to do anything
Case "QUESTION LIST"
'No need to do anything
Case Else
Color_Text (strCatViewCol & xxRow)
Add_Comment (strCatViewCol & xxRow), "Only the values: 'CATEGORY LIST' or 'QUESTION LIST' are allowed. Please verify the spelling."
Cat_Failed_Validation = True
End Select
'-----------------------------
'Check the Category Answer (Optional)
'-----------------------------
strCategoryValue = UCase(Range(strCatAnswerCol & xxRow).Value)
Select Case strCategoryValue
Case ""
'No need to do anything
Case "ENABLED"
'No need to do anything
Case "DISABLED"
'No need to do anything
Case Else
Color_Text (strCatAnswerCol & xxRow)
Add_Comment (strCatAnswerCol & xxRow), "Only the values: 'ENABLED' or 'DISABLED' are allowed. Please verify the spelling."
Cat_Failed_Validation = True
End Select
'-----------------------------
'Check the ReAudit (Optional)
'-----------------------------
strCategoryValue = UCase(Range(strCatReAuditCol & xxRow).Value)
Select Case strCategoryValue
Case ""
'No need to do anything
Case "AUDIT"
'No need to do anything
Case "BOTH"
'No need to do anything
Case "NON-COMPLIANT"
'No need to do anything
Case "REAUDIT"
'No need to do anything
Case Else
Color_Text (strCatReAuditCol & xxRow)
Add_Comment (strCatReAuditCol & xxRow), "Only the values: 'AUDIT', 'BOTH', 'NON-COMPLIANT', or 'REAUDIT' are allowed. Please verify the spelling."
Cat_Failed_Validation = True
End Select
Next
If Cat_Failed_Validation = True Then
MsgBox "Validation Failed. Please see the items in red and refer" & vbCrLf & _
"the comments in the cell for clarification."
Else
MsgBox "Validation Successful"
End If
Range("A7").Select
'Protect the sheet first
Protect_Sheet "Categories"
End Sub
Function Check_ASCII(ByVal strChar As String) As Boolean
Dim intASCII As Integer
intASCII = Asc(strChar)
'The following are the accepted characters in the ID field.
'45--> "-"
'48-57-->"0-9"
'65-90 -->"A-Z"
'95-->"_"
'97-199-->"a-z"
If (intASCII = 45) Or (intASCII > 47 And intASCII < 58) Or (intASCII > 64 And intASCII < 91) Or (intASCII = 95) Or (intASCII > 96 And intASCII < 123) Then
Else
Check_ASCII = True
End If
End Function
Sub Color_Text(Optional ByVal strRange As String)
Range(strRange).Font.ColorIndex = 3
Range(strRange).Font.bold = True
' Selection.Font.bold = True
End Sub
Sub Add_Comment(ByVal strRange As String, ByVal strMsg As String)
' Need to delete any previous comments to prevent an error. This will usually
' occur when checking the ASCII character in the Category ID field.
' Range(strRange).ClearComments
'
' Range(strRange).AddComment
' Range(strRange).comment.Visible = False
' Range(strRange).comment.Text Text:=strMsg
End Sub
Sub Clear_Comments(ByVal strRange As String)
Range(strRange).ClearComments
End Sub
Sub Reset_Font(ByVal strRange As String)
Range(strRange).Select
Selection.Font.ColorIndex = 0
Selection.Font.bold = False
End Sub
Sub Unprotect_Sheet(ByVal strSheet As String)
With Worksheets(strSheet)
.Unprotect Password:="stetonadmin"
End With
End Sub
Sub Protect_Sheet(ByVal strSheet As String)
'Turns on the Auto Filter so it can be used when the sheet is
'protected.
With Worksheets(strSheet)
.EnableAutoFilter = True
.protect Password:="stetonadmin", DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
End With
End Sub
