VBA Macro to compare then organize data - vba

Question

I'm trying to architect a macro to do the following steps:
Compare two lists of data (in this case Column A against Column C)
Output in B any cell that exists in both A and C. Line up the match next to its match in Column A.
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

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

Answer 2

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