Reorder Lines to Match

I've search for solutions to my problem and found a few that I thought might work, but they all seemed to be designed to do things slightly different than how I need them.

In the attached spreadsheet my data consists of columns A through K. Essentially I want to line up the data so Column E matches column K. When no data exists in the other section, then a blank line should be inserted. The example I gave has the data formatted the way I want it. As you can see, line 11 is blank. Column L can be ignored as my manual way to handle this was to create an if statement that returned "Error" when something didn't match.

My spreadsheet has 29,000 lines in it. So doing this with my IF statement method would take enormous amounts of time.

Any help would be appreciated!

Originally Posted by schweitzerc

The example I gave has the data formatted the way I want it.

How does before data look like?

The "before" data looks pretty much the same except there are no blank lines and the data to match in Column E and K is not matched up.

The macro I found previously is a monster. I created a named range called "Keys" for A1:E1, K1 and then ran the macro. Three hours in and it hadn't finished yet.

I'll be honest in saying I can't read this thing at all, so I don't know what it's really doing. The description they gave sounded similar to what I needed, however.

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

Works great! Thank you!