Excel

Sequence Counter

Ease of Use

Intermediate

Version tested with

2000 

Submitted by:

MWE

Description:

Counts # of sequences in a selection. Displays # found, sequence names and lengths. 

Discussion:

Counting the frequency of occurrence for unique items within a range or group of items has many uses in a variety of disciplines. A histogram is but one example of a frequency count. Most frequency counters ignore ?runs? or ?sequences? of an item. The procedure SeqCount examines an array of values for runs or sequences of consecutive items. For each sequence found, the sequence text, relative location and length of sequence is stored in arrays to be passed back to the calling procedure. SeqCount can be used in any VB or VBA application. xlSeqCount is an Excel function that builds an array of data from the current selection, calls SeqCount to process the array, and then displays the results. Upon completion of the selection examination, xlSeqCount displays the number of cells examined, the number of sequences found and a table of sequence ?names" or "values", starting locations and lengths. If requested, xlSeqCount will also write the table of sequence names/locations/lengths to a location of the user's choosing. 

Code:

instructions for use

			

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

How to use:

  1. Copy the above code.
  2. Open any workbook.
  3. Press Alt + F11 to open the Visual Basic Editor (VBE).
  4. In the left side window, hi-lite the target spreadsheet [it will likely be called VBAProject(filename.xls) where filename is the name of the spreadsheet]
  5. Select an existing code module for the target worksheet; or from the Insert Menu, choose Insert | Module.
  6. Paste the code into the right-hand code window.
  7. Close the VBE, save the file if desired.
  8. See ?Test The Code? below
 

Test the code:

  1. Open the Excel example
  2. Select a group of cells for examination (using either the sample data or additional/new data created by the user)
  3. Click on the yellow button
 

Sample File:

xlSeqCount.zip 20.47KB 

Approved by mdmackillop


This entry has been viewed 297 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express