Bill,
Re: Activesheet.Usedrange instead of UsedRange:
I have XL97, so I'm the one who is behind the times.
Re: (
http://en.wikipedia.org/wiki/Tuple)
Another neat link. I do have some math background
and have used that term in my past.
My routine doesn't need the statements
If CellV.Row <> Cell1.Row Then ' avoid loop if e.g. 7,7
End if
Re: What if the tuples are of different orders..?
This version assumes the n-tuples (variable n) start in column 3.
It puts thegroup# in col1 and the length of the tuple in col2.
I hope I can put this routine to some USE.
It certainly doesn't deal with
"loose connections" (in the social world).
Option Explicit
Dim gColl As New Collection, gRng As Range
' assumes usedrange is n-tuplets only,
' starting in column 3
' puts group# in column 1
' puts length in column 2
' lists groups to the right
Sub Main3() ' group related n-tuplets
Dim iRowV&, iCol%, iRowZ&, iColZ%, nGroup%
Set gRng = Range(Columns(3), Columns(256))
Set gRng = Intersect(ActiveSheet.UsedRange, Range(Columns(3),
Columns(256)))
' get last row, col
iRowZ = gRng.SpecialCells(xlCellTypeLastCell).Row
iColZ = gRng.SpecialCells(xlCellTypeLastCell).Column
' fill col1 with lengths
For iRowV = 1 To iRowZ ' fill col2 with lengths
Cells(iRowV, 2) = 0 ' for xlToRight
Cells(iRowV, 2) = Cells(iRowV, 2).End(xlToRight).Column - 2
Next iRowV
Columns(1).Clear ' for group#s
iRowV = 1
Do While iRowV <= iRowZ ' look for group start
If Cells(iRowV, 1) = "" Then
nGroup = nGroup + 1 ' start new group
Call AddTuplet(nGroup, iRowV)
iCol = iColZ + nGroup + 1 ' done, list this group at right
Cells(1, iCol) = nGroup ' group#
Do While gColl.Count > 0 ' get items
Cells(gColl.Count + 2, iCol).Value = gColl(gColl.Count)
gColl.Remove gColl.Count ' and remove
Loop
End If
iRowV = iRowV + 1
Loop
End Sub
Sub AddTuplet(pGroup%, pRow&) ' go thru a n-tuplet
Dim v1 As Variant, iColV%, iErr&, Cell1 As Range, CellV As Range
Cells(pRow, 1) = pGroup ' group#
For iColV = 3 To Cells(pRow, 2) + 2 ' all columns of tuple
Set Cell1 = Cells(pRow, iColV) ' starting cell
v1 = Cell1.Value ' and value
On Error Resume Next ' err if dup
gColl.Add v1, Format(v1) ' add item
iErr = Err.Number ' 457 if dup
On Error GoTo 0 ' restore err processing
If iErr = 0 Then ' if new, then do Find loop
Set CellV = gRng.Find(v1, Cell1, xlFormulas, xlWhole)
Do While CellV.Address <> Cell1.Address ' ck end
' recursively add another tuplet
Call AddTuplet(pGroup, CellV.Row)
' can't do findnext with recursion
Set CellV = gRng.Find(v1, CellV, xlFormulas, xlWhole)
Loop
End If
Next iColV
End Sub
