Excel: Sort & Match Rows - Must Handle Two Sets of Data Stacked in One Column

Sub MatchEm_10()
' Assumes that the two sets of data are in parallel columns. No data is to the right of the second set. _
     The two sets of data must start in the same row, but need not contain the same data types, or number of columns. _
     Nothing should be underneath either set of data. Blank row in the data set with the most rows terminates execution.
' The "key" must be the first column in each set of data
' The number of columns in each list is determined by looking to the right for a blank cell.
' The number of rows in each list is determined by looking down in the first column for a blank cell.
' In other words, make sure the first row and column are fully populated, and include a blank row below and _
        blank column to the right of each list
'
Dim frmla1 As String, frmla2 As String
Dim addr1 As String, addr2 As String, sRows As String
Dim celHome As Range, rgA As Range, rgB As Range, rg1 As Range, rg2 As Range, rgSort As Range
Dim nCols1 As Long, nCols2 As Long, nRows As Long, nRows1 As Long, nRows2 As Long
Dim ws As Worksheet

Set celHome = ActiveCell    'Set a "return address" for the end of the macro
On Error Resume Next        'Turn error handling off. _
                                If you don't pick a range, the InputBox function will fail. _
                                If RSLT worksheet doesn't exist, then trying to set a worksheet variable to it will fail.
Set rgA = Application.InputBox("Please pick the top left cell in set 1", Type:=8)
If rgA Is Nothing Then Exit Sub     'No range was picked, so exit sub
Set rgB = Application.InputBox("Please pick the top left cell in set 2", Type:=8)
If rgB Is Nothing Then Exit Sub     'No range was picked, so exit sub
Set ws = Worksheets("RSLT")
If ws Is Nothing Then   'RSLT worksheet does not exist, so let's add one to this workbook
    Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))    'Add the new sheet after the last worksheet in the workbook
    ws.Name = "RSLT"
End If
If ws.UsedRange.Rows.Count > 1 Then     'The RSLT worksheet already contains data. Ask user if it should be cleared.
    If MsgBox("The RSLT worksheet already contains data. Do you want to delete it?", vbYesNoCancel) <> vbYes Then Exit Sub
    ws.Cells.ClearContents      'Clear all existing data
End If
On Error GoTo 0         'Restore normal error handling

Application.ScreenUpdating = False      'Eliminate screen flicker while macro runs
nCols1 = 1      'Count the number of columns in the two lists. They don't have to be the same.
nCols2 = 1
If rgA.Cells(1, 2) <> "" Then nCols1 = rgA.End(xlToRight).Column - rgA.Column + 1   'The If test makes sure that List1 and List2 contain at least two columns of data
If rgB.Cells(1, 2) <> "" Then nCols2 = rgB.End(xlToRight).Column - rgB.Column + 1   'The .End(xlToRight) finds the cell to the left of the first blank in the row
    'Rows.Count is number of rows in the spreadsheet (varies with Excel version)
    'rgA.Worksheet returns the worksheet that contains List1; rgB.Worksheet returns the worksheet that contains List2 (need not be the same)
    'rgA.Column is column number of first cell in List1
nRows1 = rgA.End(xlDown).Row - rgA.Row + 1      'Look down from top of list to find last row in List1. Determine number of rows.
nRows2 = rgB.End(xlDown).Row - rgB.Row + 1      'Look down from top of list to find last row in List2. Determine number of rows.
nRows = IIf(nRows1 > nRows2, nRows1, nRows2)        'The number of rows in the longer list
Set rgA = rgA.Resize(nRows1, nCols1)       'All the data in List1. Resize grows the length of the range variable
Set rgB = rgB.Resize(nRows2, nCols2)       'All the data in List2. Resize could also grow the width, but that feature not needed here

With ws         'All objects or properties that begin with a . refer to worksheet RSLT
    rgA.Copy
    .Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats     'Paste values and number formats, starting in cell A1
    Set rg1 = .Cells(1, 1).Resize(nRows1, 1)            'The first column of List1, which must contain the "key"
    
    rgB.Copy    'Paste List2 with three blank columns between List1 and List2
    .Cells(1, nCols1 + 4).PasteSpecial xlPasteValuesAndNumberFormats
    Set rg2 = .Cells(1, nCols1 + 4).Resize(nRows, 1)    'The first column of List2, which must contain the "key". If List1 is longer, pad with blank rows at bottom.
    Application.Goto .Cells(1, 1)  'Select cell A1 on the RSLT worksheet. This unselects the List2 cells that had been pasted.
End With

Set rgSort = rg2.Offset(0, -2).Resize(, 2)   'The two blank columns for the auxiliary formulas
addr1 = rg1.Address(ReferenceStyle:=xlR1C1)                 'Address of List1 first column in R1C1 format
addr2 = rgSort.Columns(1).Address(ReferenceStyle:=xlR1C1)   'Address of auxiliary formula columns in R1C1 format
sRows = "ROW(R1:R" & nRows & ")"        'The ROW function returns the numbers 1 through the number of rows in the longer list.
    '
    'Returns the index number in List1 where the key from List2 matches, or error value #N/A if no match was found
frmla1 = "=MATCH(RC[2]," & addr1 & ",0)"
    '
    'Array formula that inserts the "left-over" numbers into the results from frmla1 whenever no match was found
frmla2 = "=IF(ISNA(RC[-1]),SMALL(IF(ISNA(MATCH(" & sRows & "," & addr2 & ",0))," & sRows & _
    ",""""),COUNTIF(R" & rg2.Row & "C[-1]:RC[-1],""#N/A"")),RC[-1])"
rgSort.Columns(1).FormulaR1C1 = frmla1      'Put frmla1 in the first auxiliary column
rgSort.Cells(1, 2).FormulaArray = frmla2    'Put frmla2 in the first cell of second auxiliary column, as an array formula
rgSort.Columns(2).FillDown                  'Copy down the array formula

    'Sort the auxiliary columns and List2 by the results of frmla2. This will align List2 rows with their match from List1
rgSort.Resize(, 2 + nCols2).Sort Key1:=rgSort.Cells(1, 2), Order1:=xlAscending, Header:=xlNo
rgSort.Columns(2).EntireColumn.Delete      'Delete the second auxiliary column
rgSort.Columns(1).SpecialCells(xlCellTypeFormulas, xlNumbers).ClearContents
rgSort.Columns(1).SpecialCells(xlCellTypeFormulas, xlErrors).Value = "Mismatch"

Application.Goto celHome        'Return to the original cell that was active
Application.ScreenUpdating = True
End Sub

Select allOpen in new window

Select allOpen in new window