Well, I for one cannot come up with a worksheet function or group of
functions that would do that for you, but I can come up with some VBA code to
accomplish it.
Works with any number of columns, just redefine the DataColumns() array and
fill the elements with column identifiers at the start of the code. Change
the variable FirstDataRow to point to the first row of your data to
manipulate. That allows you to have column headers if needed. Hope this
helps. It does kind of assume that your data is numeric - if it is text, you
may end up with the column header text (if there is any) mixed into the data
somewhere along the line. For numeric data, it works with or without column
headers.
Functional workbook at:
http://www.jlathamsite.com/uploads/for_DStillwell.xls
jlatham: (e-mail address removed)
Sub SegregateData()
'set up for 3 columns
'dimension this array to hold the column identifier for
'each column that holds information
Dim DataColumns(1 To 3) As String
'load up the array elements
DataColumns(1) = "A"
DataColumns(2) = "B"
DataColumns(3) = "C"
Const HelperColumn = "D" ' any empty column
Const FirstDataRow = 2 ' first row with data to alter
Dim anyAddress As String
Dim LC As Integer ' loop counter
Dim colOffset As Integer
Dim SafetyBelt As Long
Application.ScreenUpdating = False ' for speed
'begin by sorting each column individually
For LC = LBound(DataColumns) To UBound(DataColumns)
Columns(DataColumns(LC) & ":" & DataColumns(LC)).Select
anyAddress = DataColumns(LC) & "1"
Selection.Sort Key1:=Range(anyAddress), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Next
'
'now the work begins
'we are going to create a helper column
'and put all of the information from all columns into it
'and then sort it and remove duplicate entries
'
'make sure the helper column is empty
Columns(HelperColumn & ":" & HelperColumn).Select
Selection.ClearContents
'fill up any cells in helper column to
'make data placed here start at same row as data does
If FirstDataRow > 1 Then
Do Until ActiveCell.Row = FirstDataRow
ActiveCell = "Header"
ActiveCell.Offset(1, 0).Activate
Loop
End If
For LC = LBound(DataColumns) To UBound(DataColumns)
If LC > 1 Then
'for all columns after the 1st one
Range(DataColumns(LC) & FirstDataRow).Select
anyAddress = DataColumns(LC) & FirstDataRow & _
":" & Range(DataColumns(LC) & _
"65536").End(xlUp).Address
Range(anyAddress).Select
Selection.Copy
Range(HelperColumn & FirstDataRow).End(xlDown).Offset(1, 0).Select
Else
' just done for the 1st group
Range(DataColumns(LC) & FirstDataRow).Select
anyAddress = DataColumns(LC) & FirstDataRow & _
":" & Range(DataColumns(LC) & "65536").End(xlUp).Address
Range(anyAddress).Select
Selection.Copy
Range(HelperColumn & FirstDataRow).Select
End If
ActiveSheet.Paste
Next
Application.CutCopyMode = False
'now sort the helper column
Columns(HelperColumn & ":" & HelperColumn).Select
anyAddress = HelperColumn & FirstDataRow
Selection.Sort Key1:=Range(anyAddress), _
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range(anyAddress).Select ' to top of the helper column
SafetyBelt = Range(HelperColumn & "65536").End(xlUp).Row
'remove duplicates from the HelperColumn
Do Until IsEmpty(ActiveCell)
If ActiveCell = ActiveCell.Offset(1, 0) Then
ActiveCell.Offset(1, 0).Delete Shift:=xlUp
Else
ActiveCell.Offset(1, 0).Activate
End If
Loop
'
'now have to move things down in the individual columns
'
For LC = LBound(DataColumns) To UBound(DataColumns)
colOffset = Range(HelperColumn & FirstDataRow).Column - _
Range(DataColumns(LC) & FirstDataRow).Column
Range(DataColumns(LC) & FirstDataRow).Select
Do Until IsEmpty(ActiveCell) Or ActiveCell.Row > SafetyBelt
If ActiveCell > ActiveCell.Offset(0, colOffset) Then
'move this down
Selection.Insert Shift:=xlDown
End If
'check next entry
ActiveCell.Offset(1, 0).Activate
Loop
Next
'should be done now!
'get rid of the helper column contents
Columns(HelperColumn & ":" & HelperColumn).Select
Selection.ClearContents
Application.ScreenUpdating = True
Range(DataColumns(1) & "1").Select ' to top of 1st column
End Sub
