Option Explicit
' shg 2009-0330, 0930, 1218
' 2010-0511: modified IsNotLeast to improve speed
' Aligns data in rows
' Prior to running, create a named range "Keys" that includes the cells in the
' header row above the data to be aligned. The range will, in general, be disjoint.
' The data begins in the row below Keys
#Const bDebug = False
Sub AlignKeys()
AlignKeys1 wks:=ActiveSheet
End Sub
Function AlignKeys1(wks As Worksheet)
Dim rKey As Range ' cells in header row containing the first column of each dataset
Dim cell As Range ' For Each loop control variable
Dim iRow As Long ' row index
Dim iCol As Long ' column index
Dim aiCol() As Long ' array containing the column indices of Keys
Dim ar() As Range ' an array of ranges containing each of the datasets to be aligned
Dim iRng As Long ' index to range array
Dim nRng As Long ' number of ranges
Dim ab() As Boolean ' "is not least" Boolean array
Dim rRow As Range ' one row of rKey
Dim rInt As Range ' cells in a given dataset range to be pushed down
Dim rIns As Range ' union of the rInt's; range to be pushed down
'===========================================================================
#If Not bDebug Then
Application.ScreenUpdating = False
#End If
Application.Calculation = xlCalculationManual
With wks
' Validate Keys range
On Error Resume Next
Set rKey = .Range("Keys")
If Err.Number Then
MsgBox Prompt:="Named range ""Keys"" does not exist!", _
Title:="Oops", Buttons:=vbCritical
Exit Function '-------------------------------------------------->
End If
On Error GoTo 0
If rKey.Parent.Index <> wks.Index Then
MsgBox Prompt:="Named range ""Keys"" is not on sheet """ & _
wks.Name & """!", _
Title:="Oops", Buttons:=vbCritical
Exit Function '-------------------------------------------------->
End If
If rKey.Count < 2 Then
MsgBox Prompt:="Named range ""Keys"" must include at least " & _
"two cells in different columns.", _
Title:="Oops", Buttons:=vbCritical
Exit Function '-------------------------------------------------->
End If
If Intersect(rKey, .Rows(rKey.Row)).Count <> rKey.Count Then
MsgBox Prompt:="All cells of named range ""Keys"" must be in the same row.", _
Title:="Oops", Buttons:=vbCritical
Exit Function '-------------------------------------------------->
End If
'=======================================================================
' Initialize variables
' ... Size the column and range arrays
nRng = rKey.Count
ReDim aiCol(1 To nRng + 1)
ReDim ar(1 To nRng)
' ... Create an ascending array of the columns in Keys
For Each cell In rKey
iCol = iCol + 1
aiCol(iCol) = cell.Column
Next cell
aiCol(iCol + 1) = .UsedRange.Column + .UsedRange.Columns.Count
BubbleSort aiCol ' forgive me ...
' ... Re-create rKey in ascending order by column
' (Which is necessary because each range extends to the
' beginning of the range to the right; the rightmost range extends
' to the end of the used range)
Set rKey = .Cells(rKey.Row, aiCol(1))
For iRng = 2 To nRng
Set rKey = Union(rKey, .Cells(rKey.Row, aiCol(iRng)))
Next iRng
iRow = rKey.Row + 1 ' start of the data to be aligned
' ... Create the array of ranges
For iRng = 1 To nRng
Set ar(iRng) = .Range(.Cells(iRow, aiCol(iRng)), _
.Cells(.Rows.Count, aiCol(iRng)).End(xlUp))
Set ar(iRng) = ar(iRng).Resize(, aiCol(iRng + 1) - aiCol(iRng))
Next iRng
' ... Sort each range by the key column
For iRng = 1 To nRng
If ar(iRng).Rows.Count > 1 Then
ar(iRng).Sort Key1:=ar(iRng)(1), _
Order1:=xlAscending, _
DataOption1:=xlSortNormal, _
MatchCase:=False, _
Header:=xlNo, _
Orientation:=xlTopToBottom
End If
Next iRng
'=======================================================================
' Align the keys by inserting cells in each range if the key value
' is not the smallest among the other keys.
Set rRow = Intersect(rKey.EntireColumn, .Rows(iRow))
Do
Set rIns = Nothing
ab = IsNotLeast(rRow)
If WorksheetFunction.Or(ab) Then
For iRng = 1 To nRng
If ab(iRng) Then
Set rInt = Intersect(ar(iRng), .Rows(iRow))
If rIns Is Nothing Then Set rIns = rInt
Set rIns = Union(rIns, rInt)
End If
Next iRng
End If
If Not rIns Is Nothing Then
#If bDebug Then
rIns.Select
#End If
rIns.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
End If
iRow = iRow + 1
Set rRow = Intersect(rKey.EntireColumn, .Rows(iRow))
Loop While WorksheetFunction.CountA(rRow) ' quit when all keys are blank
' delete the unused rows, which may have some pushed-down formatting
Range(.Rows(iRow), .Rows(.Rows.Count)).Delete
wks.UsedRange.Select
End With
AlignKeys1 = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function
Function IsNotLeast(r As Range) As Boolean()
' Returns a boolean array the same size as Range r
' containing True if the corresponding value of r is
' greater than one or more non-empty values in r
' Cell values are compared numerically if both are numbers, else lexically
Dim ab() As Boolean ' working Boolean array
Dim i As Long ' index to ab
Dim cell1 As Range ' one cell in comparison
Dim cell2 As Range ' the other cell
ReDim ab(1 To r.Count)
For Each cell1 In r
i = i + 1
Select Case VarType(cell1.Value2)
Case vbString
For Each cell2 In r
If VarType(cell2.Value2) <> vbEmpty Then
If StrComp(cell1.Text, cell2.Text, vbTextCompare) = 1 Then ab(i) = True: GoTo NextCell1
End If
Next cell2
Case vbDouble
For Each cell2 In r
Select Case VarType(cell2.Value2)
Case vbString
If StrComp(cell1.Text, cell2.Text, vbTextCompare) = 1 Then ab(i) = True: GoTo NextCell1
Case vbDouble
If cell1.Value2 > cell2.Value2 Then ab(i) = True: GoTo NextCell1
End Select
Next cell2
Case vbEmpty
' fine, do nothing
Case vbBoolean
Application.Goto cell1
ActiveWindow.ScrollRow = cell1.Row
Application.ScreenUpdating = True
MsgBox Prompt:="Invalid key value; numbers or strings only", _
Title:="Oops", Buttons:=vbCritical
End
End Select
NextCell1:
Next cell1
IsNotLeast = ab
End Function
Function BubbleSort(av As Variant)
Dim vTmp As Variant
Dim i As Integer
Dim bSwap As Boolean
Do
bSwap = False
For i = LBound(av) To UBound(av) - 1
If av(i) > av(i + 1) Then
bSwap = True
vTmp = av(i)
av(i) = av(i + 1)
av(i + 1) = vTmp
End If
Next i
Loop While bSwap
End Function
