Option Explicit
Sub SeqCount(X, NumSeq, SeqName, SeqSize, SeqLocn)
'
'****************************************************************************************
' Title SeqCount
' Target Application: any
' Function: finds sequences within a data array
' Passed Values
' X [input, array of any type] array of data to be searched. X can be of
' any type and can be either zero or one based. SeqCount tests for the
' effective length of X and exits with NumSeq = 0 if the useful length
' of X < 2
' NumSeq [returned, integer or long] number of sequences found
' SeqName [returned, array of type string] names of sequences; on return,
' SeqName has been ReDimed at size = NumSeq
' SeqSize [returned, array of type int or long] lengths of sequences; on return,
' SeqSize has been ReDimed at size = NumSeq
' SeqLocn [returned, array of type int or long] relative locations of sequences;
' on return SeqLocn has been ReDimed at size = NumSeq
'
'****************************************************************************************
'
'
Dim I As Long
Dim Seq As Boolean
NumSeq = 0
'
' test for useful X
'
If UBound(X) < LBound(X) + 1 Then
Exit Sub
End If
Seq = False
'
' sequence through data array
'
For I = LBound(X) + 1 To UBound(X)
'
' test current value against old value
' if the same ==> sequence (either starting or continuing)
'
If X(I) = X(I - 1) Then
'
' test for continuing or new sequence
'
If Seq = True Then
SeqSize(NumSeq) = SeqSize(NumSeq) + 1
Else
NumSeq = NumSeq + 1
ReDim Preserve SeqName(NumSeq)
ReDim Preserve SeqSize(NumSeq)
ReDim Preserve SeqLocn(NumSeq)
SeqName(NumSeq) = X(I)
SeqSize(NumSeq) = 2
SeqLocn(NumSeq) = I - 1
End If
Seq = True
Else
Seq = False
End If
Next I
End Sub
Sub xlSeqCount()
'
'****************************************************************************************
' Title xlSeqCount
' Target Application: MS Excel
' Function: examines current selection for sequences
' Limitations: handles selection in the standard across then down method; thus
' sequences that run down a multi-column selection will not be found
' Passed Values: none
'
'****************************************************************************************
'
'
Dim Ans As VbMsgBoxResult
Dim Cell As Range
Dim Col As Long
Dim DisplayCell As Range
Dim I As Long
Dim Num As Long
Dim NumSeq As Long
Dim ProcTitle As String
Dim Row As Long
Dim SeqLocn() As Long
Dim SeqSize() As Long
Dim SeqName() As String
Dim strBuffer As String
Dim X() As String
Num = 0
NumSeq = 0
strBuffer = ""
ProcTitle = "Sequence Counting"
'
' sequence through each cell in selection and store value in X
'
For Each Cell In Selection
Num = Num + 1
ReDim Preserve X(Num)
X(Num) = Cell.Text
Next Cell
'
' call SeqCount to actually do sequence identification and counting
'
Call SeqCount(X, NumSeq, SeqName, SeqSize, SeqLocn)
'
' store count data for display
'
For I = 1 To NumSeq
If SeqName(I) = "" Then
strBuffer = strBuffer & "<blank>" & vbTab & SeqLocn(I) & vbTab & _
SeqSize(I) & vbCrLf
Else
strBuffer = strBuffer & SeqName(I) & vbTab & SeqLocn(I) & vbTab & _
SeqSize(I) & vbCrLf
End If
Next I
'
' display results
'
MsgBox "xlSeqSize" & vbCrLf & vbCrLf & _
"# cells examined = " & Str(Num) & vbCrLf & _
"# sequences found = " & NumSeq & vbCrLf & vbCrLf & _
" Seq" & vbTab & "Locations" & vbTab & "Counts:" & vbCrLf & _
"Value" & vbCrLf & strBuffer, vbInformation, _
ProcTitle
'
' write to worksheet?
'
WriteOut:
If NumSeq > 0 Then
Ans = MsgBox("Ok to write out results to the current worksheet?" & vbCrLf & vbCrLf & _
"results will be 3 cols wide by " & (NumSeq + 1) & " rows long" & _
vbCrLf & vbCrLf & _
"NOTE:" & vbTab & "if you respond YES, you will be asked where to write out" & vbCrLf & _
vbTab & "results; and the subseqeunt writeout range will be checked " & vbCrLf & _
vbTab & "for any current data.", _
vbQuestion + vbYesNo, ProcTitle)
If Ans <> vbYes Then Exit Sub
Set DisplayCell = _
Application.InputBox("Select a cell for the upper left corner" & _
"of the area for results", , "", , , , , 8)
TestDisplayCell:
If DisplayCell.Columns.Count > 1 Or DisplayCell.Rows.Count > 1 Then
Set DisplayCell = _
Application.InputBox("Select a SINGLE cell for the upper left corner" & _
"of the area for results", , "", , , , , 8)
Goto TestDisplayCell
End If
Col = DisplayCell.Column
Row = DisplayCell.Row
If xlIsBlank(Range(Cells(Row, Col), Cells(Row + NumSeq, Col + 2))) = False Then
Ans = MsgBox("There is data in cells specified for the results." & vbCrLf & _
"Are you SURE you want to write out the results?" & vbCrLf & vbCrLf & _
"[enter No to respecify where results are written]" & vbCrLf & _
"[enter Cancel to just exit the process]", _
vbCritical + vbYesNoCancel, ProcTitle)
If Ans = vbCancel Then Exit Sub
If Ans = vbNo Then Goto WriteOut
End If
Cells(Row, Col) = "Seq Value"
Cells(Row, Col + 1) = "Locn"
Cells(Row, Col + 2) = "Count"
For I = 1 To NumSeq
If SeqName(I) <> "" Then
Cells(Row + I, Col) = SeqName(I)
Else
Cells(Row + I, Col) = "<blank>"
End If
Cells(Row + I, Col + 1) = SeqLocn(I)
Cells(Row + I, Col + 2) = SeqSize(I)
Next I
End If
Set DisplayCell = Nothing
End Sub
Function xlIsBlank(TargetRange As Range) As Boolean
'
'****************************************************************************************
' Title xlIsBlank
' Target Application: MS Excel
' Function tests for any data in the target range
' if no data found in any cell in the range, the xlIsBlank = True
' if data found in any cell in the range, then xlIsBLank = False
' Limitations: NONE
' Passed Values: TargetRange
'
'****************************************************************************************
'
'
Dim DataCol As Long
With TargetRange
If Trim(.Cells(1)) <> "" Then
xlIsBlank = False
Exit Function
End If
On Error Resume Next
DataCol = .Cells.Find("*", .Cells(1), xlFormulas, _
xlWhole, xlByColumns, xlPrevious).Column
If Err <> 0 Then DataCol = 0
End With
If DataCol = 0 Then
xlIsBlank = True
Else
xlIsBlank = False
End If
End Function
|