Option Explicit
Sub SeqCount(X, NumSeq, SeqName, SeqSize, SeqLocn)
Dim I As Long
Dim Seq As Boolean
NumSeq = 0
If UBound(X) < LBound(X) + 1 Then
Exit Sub
End If
Seq = False
For I = LBound(X) + 1 To UBound(X)
If X(I) = X(I - 1) Then
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()
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"
For Each Cell In Selection
Num = Num + 1
ReDim Preserve X(Num)
X(Num) = Cell.Text
Next Cell
Call SeqCount(X, NumSeq, SeqName, SeqSize, SeqLocn)
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
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
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
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
|