Extracting a list of individual values created with sum of values

[OssieMac]

Hello All,

The following code sums values created using 2 ^ n for various invalid data.
There is a method of then extracting the individual values from the summed
total to identify the individual messages. I can’t remember how to do this
and have not been successful in finding it so any help will be appreciated.

I know there are other ways of creating the list of messages but I
particularly want the code for this method. (The code below is simply an
example. What I am really after is code to create an individual number to use
as an argument/parameter in a different situation. I can create the number as
below but cannot extract the individual values that have been summed.)

Sub Test_Valid_Range()

'Invalid data table.
'2 ^ 0 = 1 Header row not included in selection.
'2 ^ 1 = 2 Require minimum 2 rows and 2 columns.
'2 ^ 2 = 4 Blank column headers not permitted.
'2 ^ 3 = 8 Duplicate column headers not permitted.
'2 ^ 4 = 16 Blank data cells not permitted.

Dim rngSelect As Range
Dim lngInvalid As Long
Dim i As Long
Dim strMsge As String

On Error Resume Next
Set rngSelect = Application.InputBox _
(Prompt:="Select the required range", Type:=8)
If rngSelect Is Nothing Then
MsgBox "No range selected or user cancelled." & vbLf & _
"Processing terminated."
Exit Sub
End If

lngInvalid = 0
With rngSelect
'Test that header row is included in selection
If .Cells(1, 1).Row <> 1 Then
lngInvalid = lngInvalid + 2 ^ 0
End If

'Test for at least 2 rows and 2 columns
If .Rows.Count < 2 Or .Columns.Count < 2 Then
lngInvalid = lngInvalid + 2 ^ 1
End If

'Test for no blank column headers
If WorksheetFunction.CountBlank(.Rows(1)) > 0 Then
lngInvalid = lngInvalid + 2 ^ 2
End If

'Test for duplicate column headers
For i = 1 To .Columns.Count
If WorksheetFunction.CountIf(.Rows(1), _
.Cells(1, i)) > 1 Then
lngInvalid = lngInvalid + 2 ^ 3
Exit For 'Must cease testing on first duplicate
End If
Next i

'Test for blank cells within data range.
If WorksheetFunction.CountBlank(.Range(.Cells(2, 1), _
.Cells(.Rows.Count, .Columns.Count))) > 0 Then
lngInvalid = Invalid + 2 ^ 4
End If

End With

MsgBox lngInvalid 'for testing only

'*************************************
'How to process the sum of lngInvalid
'to extract individual values to match to messages.
'*************************************
End Sub

 

[Ron Rosenfeld]

Hello All,

The following code sums values created using 2 ^ n for various invalid data.
There is a method of then extracting the individual values from the summed
total to identify the individual messages. I can’t remember how to do this
and have not been successful in finding it so any help will be appreciated.

I know there are other ways of creating the list of messages but I
particularly want the code for this method. (The code below is simply an
example. What I am really after is code to create an individual number to use
as an argument/parameter in a different situation. I can create the number as
below but cannot extract the individual values that have been summed.)

Sub Test_Valid_Range()

'Invalid data table.
'2 ^ 0 = 1 Header row not included in selection.
'2 ^ 1 = 2 Require minimum 2 rows and 2 columns.
'2 ^ 2 = 4 Blank column headers not permitted.
'2 ^ 3 = 8 Duplicate column headers not permitted.
'2 ^ 4 = 16 Blank data cells not permitted.

'*************************************
'How to process the sum of lngInvalid
'to extract individual values to match to messages.
'*************************************
End Sub

One way is to convert the value, which should be in the range 0 to 31, into a
binary string, then test each bit for a one or a zero.
--ron

 

[Gary''s Student]

Sub MessageExtractor()
Dim lngInvalid As Integer
Dim Mesage(1 To 5) As String
Dim s As String
Mesage(1) = "Blank data cells not permitted"
Mesage(2) = "Duplicate column headers not permitted"
Mesage(3) = "Blank column headers not permitted"
Mesage(4) = "Require minimum 2 rows and 2 columns"
Mesage(5) = "Header row not included in selection"
explanation = ""
lngInvalid = 31
s = dec2bin(lngInvalid)
For i = 1 To 4
If Mid(s, i, 1) = "1" Then
If explanation = "" Then
explanation = Mesage(i)
Else
explanation = explanation & vbLf & Mesage(i)
End If
End If
Next
MsgBox explanation
End Sub


Here we convert the value (as an integer!) to binary (really a string) and
look at the individual bits.

Make sure you reference the ATP to get access to DEC2BIN()

 

[Gary''s Student]

Sorry, use:
s = dec2bin(lngInvalid, 4)
instead

 

[OssieMac]

Thankyou Ron and Gary''s Student. My Seniors moment passed as soon as I saw
the answer. I modified Gary''s Student's code to make it a bit more generic
whereby the length of the binary string is variable and and I am able to
extract the values from the lowest to the highest. Also while I like the 1
based arrays, I think this is a case for justifying the zero based array so
that the elements of the array match the power.

Thankyou both once again and here is my modified code in case it can help
anyone else. (If used then the code in my original post on this thread will
also be needed.)

Dim s As String
Dim i As Integer
Dim j As Integer
Dim strMsge As String
Dim Mesage(0 To 4) As String

Mesage(0) = "Header row must be included in selection."
Mesage(1) = "Require minimum 2 rows and 2 columns."
Mesage(2) = "Blank column headers not permitted"
Mesage(3) = "Duplicate column headers not permitted."
Mesage(4) = "Blank data cells not permitted."

s = WorksheetFunction.Dec2Bin(lngInvalid)
j = 0 'Initialize
For i = Len(s) To 1 Step -1
If Mid(s, i, 1) = "1" Then
If strMsge = "" Then
strMsge = Mesage(j)
Else
strMsge = strMsge & vbLf & Mesage(j)
End If
End If
j = j + 1
Next

MsgBox strMsge

 

[Chip Pearson]

You will find that using an Enum will make your life much easier. For
example, adapting your example code gives us the enum

Public Enum DataTableError
Success = 0
NoHeaderRow = 2 ^ 0
MinRowColError = 2 ^ 1
BlankHeader = 2 ^ 2
DuplicateHeader = 2 ^ 3
BlankData = 2 ^ 4
End Enum

Then, in your code, you can assign values to a variable declared As
DataTableError. E.g.,

Dim DataTableErr As DataTableError
DataTableErr = Success
If Something Then
' assign error for blank header
DataErr = DataErr Or BlankHeader
End If
If SomethingElse Then
' assign error for blank data
DataErr = DataErr Or BlankData
End If

Then, you can test for a specific error with:

If DataTableErr And BlanKHeader Then
Debug.Print "Table has blank header."
End If

Or, you can test to see if any error occurred:

If DataTableErr = Success Then
Debug.Print "Success"
Else
Debug.Print "Some error(s): " & "&h" & Hex(DataErr)
End If

A few things about enums: The are simply named Long data types -- you
cannot put Strings or Doubles in an Enum. There is no way to enforce
that a value assigned to an enum is a valid value. E.g., there is
nothing to prevent the assignment
DataErr = 1234,
even though 1234 is not valid for that enum. There is no way to get
the name of the named value of an enum. That is, given the value 8,
there is no way to go back and get the text "DuplicateHeader". If you
want to wrap the enum up inside a Property Get/Let pair, you could
have code that validates an assigned valule and/or returns the string
name, but an enum by itself cannot validate or name itself.

See http://www.cpearson.com/excel/Enums.aspx for more details about
working with enums.


Cordially,
Chip Pearson
Microsoft MVP 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com
[email on web site]

 

[OssieMac]

Thankyou Chip.

I really like expanding my knowledge with these other options and I
particularly like this one. Just for other peoples interest I have posted my
full test code. Only need to set up a spreadsheet with headers in the first
row and some dummy data below. Try with variations of duplicated header,
blank headers and blank data to see how well the method works.

Option Explicit

Public Enum DataTableError
Success = 0
NoHeaderRow = 2 ^ 0
MinRowColError = 2 ^ 1
BlankHeader = 2 ^ 2
DuplicateHeader = 2 ^ 3
BlankData = 2 ^ 4
End Enum

Sub Test_Enum_Method()
'Using Chip Pearsons method with Enum
Dim rngSelect As Range
Dim lngInvalid As Long
Dim i As Long
Dim dataError As DataTableError
Dim strMsge As String

On Error Resume Next
Set rngSelect = Application.InputBox _
(Prompt:="Select the required range", Type:=8)
If rngSelect Is Nothing Then
MsgBox "User cancelled." & vbLf & _
"Processing terminated."
Exit Sub
End If

dataError = Success

With rngSelect
'Test that header row included in selection
If .Cells(1, 1).Row <> 1 Then
dataError = dataError Or NoHeaderRow
GoTo ErrorMessage 'Header required for further testing
End If

'Test for no blank column headers
If WorksheetFunction.CountBlank(.Rows(1)) > 0 Then
dataError = dataError Or BlankHeader
End If

'Test for duplicate column headers
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
If .Rows.Count < 2 Or .Columns.Count < 2 Then
dataError = dataError Or MinRowColError
GoTo ErrorMessage 'Min selection required for next test
End If

'Test for blank cells within data range.
If WorksheetFunction.CountBlank _
(.Offset(1, 0) _
.Resize(.Rows.Count - 1, _
.Columns.Count)) > 0 Then

dataError = dataError Or BlankData
End If

End With

ErrorMessage:
If dataError = Success Then
strMsge = strMsge & "Success"
GoTo myMessage 'Skip remaining tests
End If

If dataError And NoHeaderRow Then
strMsge = strMsge & "NoHeaderRow" & vbLf
End If

If dataError And MinRowColError Then
strMsge = strMsge & "MinRowColError" & vbLf
End If

If dataError And BlankHeader Then
strMsge = strMsge & "BlankHeader" & vbLf
End If

If dataError And DuplicateHeader Then
strMsge = strMsge & "DuplicateHeader" & vbLf
End If

If dataError And BlankData Then
strMsge = strMsge & "BlankData" & vbLf
End If

'Remove trailing line feed
strMsge = Left(strMsge, (Len(strMsge) - 1))

myMessage:
MsgBox strMsge

End Sub