Comparing Data: Multiple Variables

[jomili]

In the attached file are two spreadsheets. On the "Former_Workspace" worksheet, in a former thread (http://www.excelforum.com/excel-prog...ring-data.html) SHG gave me a great macro to line up the two sets of data (columns A:B and D:F) so I could figure the differences in the Position Function Code totals. That macro is below, and works very well.

I've complicated things by adding another field, the PAC (Program Area), as you can see in the "Workspace" tab. Now I need to line it up by PAC, and within PAC by Position Function code. I tried using the same macro by naming the "Keys" range to include the PACs, but all that did was wipe out the PACs. So, I need help yet again. Any help you can provide to do my comparing would be greatly appreciated.

Option Explicit

' shg 2009-0330, 0930, 1218

' 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

' The keys must be either all numeric or all text.

Sub AlignKeys()
    AlignKeys1 wks:=ActiveSheet, bDebug:=False
End Sub

Function AlignKeys1(wks As Worksheet, Optional bDebug As Boolean = False)
    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

    '===========================================================================
    Application.ScreenUpdating = bDebug
    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!", _
                   Buttons:=vbInformation, Title:="Oops!"
            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 & """!", _
                   Buttons:=vbInformation, Title:="Oops!"
            Exit Function   '-------------------------------------------------->
        End If

        If rKey.Count < 2 Then
            MsgBox Prompt:="Named range ""Keys"" must include at least " & _
                           "two cells in different columns.", _
                   Buttons:=vbInformation, Title:="Oops!"
            Exit Function   '-------------------------------------------------->
        End If

        If Intersect(rKey, .Rows(rKey.Row)).Count <> rKey.Count Then
            MsgBox "All cells of named range ""Keys"" must be in the same row.", _
                   Buttons:=vbInformation, Title:="Oops!"
            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
        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

        ' ... 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
                rIns.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
            End If

            iRow = iRow + 1
            Set rRow = Intersect(rKey.EntireColumn, .Rows(iRow))
        Loop Until WorksheetFunction.CountA(rRow) = 0   ' 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.Count
    ' containing True if the corresponding value of r is
    ' greater than one or more non-empty values in r

    ' Cells 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
        If Not IsEmpty(cell1.Value2) Then
            For Each cell2 In r
                If Not IsEmpty(cell2.Value2) Then
                    If WorksheetFunction.Count(cell1, cell2) = 2 Then
                        If cell1.Value2 > cell2.Value2 Then ab(i) = True
                    Else
                        If StrComp(cell1.Text, cell2.Text, vbTextCompare) = 1 Then ab(i) = True
                    End If
                End If
            Next cell2
        End If
    Next cell1

    IsNotLeast = ab
End Function

Function BubbleSort(av As Variant)
    Dim vTmp        As Variant
    Dim i           As Integer
    Dim bNoSwp      As Integer

    Do
        bNoSwp = True

        For i = LBound(av) To UBound(av) - 1
            If av(i) > av(i + 1) Then
                bNoSwp = False
                vTmp = av(i)
                av(i) = av(i + 1)
                av(i + 1) = vTmp
            End If
        Next i
    Loop Until bNoSwp
End Function