VBA Macro to compare then organize data

Question

I'm trying to architect a macro to do the following steps:

1. Compare two lists of data (in this case Column A against Column C)

2. Output in B any cell that exists in both A and C. Line up the match next to its match in Column A.

3. Sort both column A and B by their values so that the corresponding cells in A and B are still next to each other after the sort.

Desired result. Notice how the matches in column A and B are still together. This enables users of this macro to quickly eliminate data that only belongs to one of the respective columns and it allows us to retain any information that may be tied to column A, e.g., Column A contains email addresses, and there is a corresponding column next to it that contains phone #'s. We don't want to split that information up. This macro would enable that:

Pastebin of excel data I used: http://pastebin.com/mYuQRMjj

This is the macro I've written, which uses a second macro:

Sub Macro()

        Range(Selection, Selection.End(xlDown)).Select
        Application.Run "macro4.xlsm!Find_Matches"
        Range("B1:B284").Select
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B284") _
             , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
             .SetRange Range("A1:B284")
             .Header = xlGuess
             .MatchCase = False
             .Orientation = xlTopToBottom
             .SortMethod = xlPinYin
             .Apply

    End With

End Sub

The second macro that does the comparison is literally ripped straight from Microsoft, with a little extra.

Sub Find_Matches()
Application.ScreenUpdating = False
     Dim CompareRange As Variant, x As Variant, y As Variant
     ' Set CompareRange equal to the range to which you will
     ' compare the selection.
     Set CompareRange = Range("C1:C500")
     ' NOTE: If the compare range is located on another workbook
     ' or worksheet, use the following syntax.
     ' Set CompareRange = Workbooks("Book2"). _
     '   Worksheets("Sheet2").Range("C1:C5")
     '
     ' Loop through each cell in the selection and compare it to
     ' each cell in CompareRange.
     For Each x In Selection
         For Each y In CompareRange
             If x = y Then x.Offset(0, 1) = x
         Next y
     Next x
 Application.ScreenUpdating = True
 End Sub

Using these two macros, I get exactly what I want, but I don't like using limited ranges. I want the macro to be smart enough to determine exactly what the range is, because the people who will be using this macro sometimes will be using a list of 200, sometimes a list of 2,000,000. I want this macro to be a "one size fits all" for range.

I looked into this and the command:

Range(Range("B1"),Range("A1").End(xlDown)).Select

gets exactly the selection I want after Find_Matches runs (I also realize that Find_Matches is using a finite compare range . . . solving my issue for this first Macro will solve that too).

The problem is that I am unsure how to plug that into my Macro. I've tried several implementations and I'm flat out stuck. I can't find an answer for something this specific, but I know I'm very close. Thank you for any help!

edit: This whole method is realllly slow on larger lists (20+ minutes on a list of 100k). If you can suggest some ways to speed it up that would be super helpful!

Answer 1

See Error in finding last used cell in VBA for the best way to find the last row of data.

Find the last row and then change your range selection to:

Range("C1:C"&Trim(CStr(lastrow)))

To speed up your macro execution start your macro with:

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

and to restore autocalc and screen updates, end your macro with:

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.Calculate

Answer 2

Sub MatchNSort()
Dim lastrow As Long

    'Tell Excel to skip the calculation of all cells and the screen
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    'Find the last row in the data
    With ActiveSheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastrow = .Cells.Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        Else
            lastrow = 1
        End If
    End With

    'Force a formula in column B to match a from c
    ActiveSheet.Range("B1:B" & lastrow).Formula = _
    "=IFERROR(IF(MATCH(C[-1],C[1]:C[1],0)>0,C[-1],""""),"""")"

    'Force a recalculate
    Application.Calculate

    'Sort columns B and A
    With ActiveSheet
        .Range("A1:B" & lastrow).Select
        .Sort.SortFields.Clear

        'First key sorts column B
        .Sort.SortFields.Add Key:=Range("B1:B" & lastrow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending _
        , DataOption:=xlSortNormal

        'Second key (optional) sort column A, after defering to column B
        .Sort.SortFields.Add Key:=Range("A1:A" & lastrow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending _
        , DataOption:=xlSortNormal

        .Sort.SetRange Range("A1:B" & lastrow)
        .Sort.Header = xlGuess
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply

    End With

    'Return autocalulation and screen updates
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.Calculate

End Sub