View Single Post
  #10   Report Post  
Posted to microsoft.public.excel.programming
Bill Renaud Bill Renaud is offline
external usenet poster
 
Posts: 417
Default A little variation of conventional sorting

This version does not use recursion, but it does parse your data out first,
if it is in a single column with commas between connection pairs. It also
adds headers (column labels) at the top of the worksheet. The data is moved
1 column to the right to make room for the Group numbers, which are
inserted in column A. The data is sorted by Group number, then by
Connection number at the end. I did not write a routine to renumber the
Groups to be consecutive.

'----------------------------------------------------------------------
'Sorts pairs of connections together by Group number,
'but does not renumber the Groups to be consecutive
'after some groups are merged into single groups.

Public Sub RegroupConnectionData()
'Code by Bill Renaud.
Dim wsData As Worksheet 'Worksheet containing the data.
Dim rngAllData As Range 'Add connection data and headers.
Dim lngLastRow As Long 'The last row of data to process.
Dim rngCurrentRow As Range 'Reference to single cell in column $A.
Dim rngSearchRange As Range 'Previous rows of connections.
Dim ilngRow As Long 'Index to current row of data.
Dim lngGroup As Long 'Last Group number assigned.
Dim lngConn1 As Long 'First connection listed on the row.
Dim lngConn2 As Long 'Second connection listed on the row.
Dim lngGroup1 As Long 'Group number of lngConn1.
Dim lngGroup2 As Long 'Group number of lngConn2.

Application.ScreenUpdating = False

'Assume the active worksheet is the one to process.
Set wsData = ActiveSheet

InitializeDataWorksheet wsData

Set rngAllData = wsData.UsedRange

With rngAllData
lngLastRow = .Row + .Rows.Count - 1
If lngLastRow < 3 Then GoTo ExitSub 'No more data to process.
End With

'First row of data is automatically Group 1.
lngGroup = 1
wsData.Range("A2").Value = lngGroup

'Initialize other variables to start iterative process.
With wsData
Set rngCurrentRow = .Range("A3")
Set rngSearchRange = .Range("B2:C2")
End With

For ilngRow = 3 To lngLastRow
'Get value of each connection.
lngConn1 = rngCurrentRow.Offset(ColumnOffset:=1).Value
lngConn2 = rngCurrentRow.Offset(ColumnOffset:=2).Value

'Now determine if either connection belongs to a previous group.
'If 0 is returned, then connection was not found in previous data.
lngGroup1 = GetGroup(lngConn1, rngSearchRange)
lngGroup2 = GetGroup(lngConn2, rngSearchRange)

If (lngGroup1 = 0) And (lngGroup2 = 0) _
Then
'Assign a new Group number. Just use the next higher number,
'even if a lower number is now available because of merging.
lngGroup = lngGroup + 1
rngCurrentRow.Value = lngGroup
Else
If (lngGroup1 < 0) And (lngGroup2 < 0) _
And (lngGroup1 < lngGroup2) _
Then
With Application.WorksheetFunction
'Assign the lowest Group number to this connection.
rngCurrentRow.Value = .Min(lngGroup1, lngGroup2)

'Merge the higher numbered Group with the lower Group.
MoveGroup .Max(lngGroup1, lngGroup2), _
.Min(lngGroup1, lngGroup2), _
rngAllData
End With
Else
With Application.WorksheetFunction
'One of the connections belongs to a previous
'Group or both belong to the same Group.
'Assign the highest Group number to this connection.
rngCurrentRow.Value = .Max(lngGroup1, lngGroup2)
End With
End If
End If

'Move pointers.
Set rngCurrentRow = rngCurrentRow.Offset(1, 0)
With rngSearchRange
Set rngSearchRange = .Resize(RowSize:=.Rows.Count + 1)
End With
Next ilngRow

'Autofit columns of data, freeze window pane.
FinishFormatting wsData

ExitSub:
End Sub

'----------------------------------------------------------------------
Private Sub InitializeDataWorksheet(wsData As Worksheet)
With wsData
'Parse comma-separated data out to separate columns
'(works even if not needed).
.UsedRange.TextToColumns DataType:=xlDelimited, Comma:=True

'Insert column at the left to hold Group numbers.
.Columns("A").Insert

'Create header row on row 1.
.Rows(1).Insert
.Range("A1").Value = "Group"
.Range("B1").Value = "Conn1"
.Range("C1").Value = "Conn2"
With .Range("A1:C1")
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetGroup(Connection As Long, _
SearchRange As Range) _
As Long

Dim rngFindResult As Range

On Error Resume Next

Set rngFindResult = SearchRange.Find(What:=Connection, _
LookIn:=xlValues, _
LookAt:=xlWhole)

If rngFindResult Is Nothing _
Then
'Connection not found in previous connections.
GetGroup = 0
Else
'Return Group number from column $A.
GetGroup = rngFindResult.EntireRow.Cells(1, 1).Value
End If
End Function

'----------------------------------------------------------------------
Private Sub MoveGroup(FromGroup As Long, _
ToGroup As Long, _
rngData As Range)

Dim rngGroup As Range 'Cells in the entire Group column.
Dim rngFromGroup As Range 'Cells in the Group column to be renumbered.

With rngData
Set rngGroup = .Resize(RowSize:=.Rows.Count - 1, ColumnSize:=1) _
.Offset(RowOffset:=1)
End With

rngData.AutoFilter Field:=1, Criteria1:="=" & CStr(FromGroup)

Set rngFromGroup = rngGroup.SpecialCells(xlCellTypeVisible)

'Convert Group from old value to new value to merge with ToGroup.
rngFromGroup.Value = ToGroup

'Turn AutoFilter off.
rngData.Parent.AutoFilterMode = False
End Sub

'----------------------------------------------------------------------
Private Sub FinishFormatting(wsData As Worksheet)
Dim rngData As Range

Set rngData = wsData.UsedRange

With rngData
'Sort the final list of data in ascending
'order by Group, Conn1, and Conn2.
.Sort Key1:="Group", Order1:=xlAscending, _
Key2:="Conn1", Order2:=xlAscending, _
Key3:="Conn2", Order3:=xlAscending, _
Header:=xlYes, _
Orientation:=xlTopToBottom

'Autofit column widths to fit the data.
.Columns.AutoFit
End With

'Freeze window at row 2 of the data.
wsData.Range("A2").Activate
wsData.Parent.Windows(1).FreezePanes = True
End Sub

--
Regards,
Bill Renaud