Hi Paul,
The lockups and failure to run are definitely caused by code errors.
I have researched and found what I believe is a better method of validating
a range and returning the function value. (Thanks to Chip Pearson MVP)
It uses Enum. See
http://www.cpearson.com/excel/Enums.aspx for more details
about working with enums.
In the Enum declaration you can add more variables for more testing. Simply
increment the power by 1 for the value for each variable that you add. Of
course you will need more code in the function and more in the SrcRef_Exit to
concatenate the strMsge.
Basically it assigns a number created by 2 power n (2^n) where n is 0 to 4
in this case. It sums the values for each of the errors and then with the use
of a binary comparison you can identify which messages to concatenate.
Don’t know how much you know about binary but Google some information on
binary and decimal to binary if you need more information. (Worksheet
function DEC2BIN actually converts decimal number to binary but it is not
required here.)
The function code needs to be logical and terminate the function if an
invalid selection is found which will affect further testing. See the
comments in the code re this.
Try the code in a new workbook. Create a simple userform with a RefEdit
control named ‘SrcRef’ and a couple of text boxes. (Textboxes so the cursor
can be moved off the SrcRef control.)
Set up some dummy data on a worksheet with column headers in the first row
on the worksheet and a few rows of dummy data below it.
Show the worksheet and test the RefEdit field. You will need to close the
userform to make changes to the worksheet to apply errors like blank headers,
duplicate headers etc.
If you can’t successfully modify the code to perform all of the tests you
require on the selected range then let me know what other tests are required
(and which ones are not required) and I will modify it for you.
The following code is tested and works. Form must be modal. (ShowModal = True)
Copy the following code into your Forms Module.
Private Sub SrcRef_Exit _
(ByVal Cancel As MSForms.ReturnBoolean)
Dim rngSrcRef As Range
Dim strMsge As String
Dim dataErr As Long
'Assign the controls range to a variable
Set rngSrcRef = Range(SrcRef.Value)
'Pass the range variable as an argument
'for the Function.
'Function returns a long number equal to
'the sum of the errors expressed as 2 ^ n
dataErr = Valid_Range_Selection(rngSrcRef)
If dataErr = Success Then 'If dataErr is zero
Exit Sub 'No errors so exit
Else
'Start concatenating the error messages.
strMsge = "Errors:"
'Data is compared in the following If's.
'It simply tests if the bit is turned on
'for the variable value.
If dataErr And NoHeaderRow Then
strMsge = strMsge & vbLf & _
"Header Row not in selection."
End If
If dataErr And BlankHeader Then
strMsge = strMsge & vbLf & _
"Blank cell/s in Header Row."
End If
If dataErr And DuplicateHeader Then
strMsge = strMsge & vbLf & _
"Duplicate Header name/s."
End If
If dataErr And MinRowColError Then
strMsge = strMsge & vbLf & _
"Min 2 Rows and 2 Cols required."
End If
If dataErr And blankdata Then
strMsge = strMsge & vbLf & _
"Blank cells in data range."
End If
MsgBox strMsge
'Setting Cancel to True cancels the
'Exit and cursor remains in the control.
Cancel = True
End If
End Sub
Copy the following code between the asterisk lines
to the top of a standard module.
Note the comments.
'**************************************
'The section between the asterisk lines
'must be in the declarations area
'at the top of a standard module
'and before any other subs.
Public Enum DataTableError
Success = 0
NoHeaderRow = 2 ^ 0
BlankHeader = 2 ^ 1
DuplicateHeader = 2 ^ 2
MinRowColError = 2 ^ 3
blankdata = 2 ^ 4
End Enum
'*************************************
Copy the following Function code into the standard module.
Function Valid_Range_Selection _
(ByVal rngToTest As Range) As Long
Dim dataError As SelectError
Dim i As Long
Dim strMsge As String
dataError = Success 'Assume correct. (Equals zero)
With rngToTest
'Test if header row included in selection.
'Tests if 1st row of selection is 1st row
'on the worksheet.
If .Rows(1).Row <> 1 Then
dataError = dataError Or NoHeaderRow
'Header required for further testing
'so to avoid code errors, skip further
'testing if header row not in selection.
GoTo EndTest
End If
'Test for no blank column headers.
'Counts blanks in 1st row of selected range.
If WorksheetFunction.CountBlank(.Rows(1)) > 0 Then
dataError = dataError Or BlankHeader
End If
'Test for duplicate column headers.
'CountIf counts number of occurrences
'of each value in the header.
For i = 1 To .Columns.Count
If WorksheetFunction.CountIf(.Rows(1), _
.Cells(1, i)) > 1 Then
dataError = dataError Or DuplicateHeader
Exit For 'Cease testing on first duplicate
End If
Next i
'Test for at least 2 rows and 2 columns.
'Counts columns and rows in selected range.
If .Rows.Count < 2 Or .Columns.Count < 2 Then
dataError = dataError Or MinRowColError
'Min 2 rows & 2 cols required for next
'test so to avoid code errors, skip
'further testing.
GoTo EndTest
End If
'NOTE: Not sure if this test required.
'Tests for blank cells within actual data
'range below the header row.
If WorksheetFunction.CountBlank _
(.Offset(1, 0) _
.Resize(.Rows.Count - 1, _
.Columns.Count)) > 0 Then
dataError = dataError Or blankdata
End If
End With
EndTest:
Valid_Range_Selection = dataError
End Function
