比较VBA宏然后组织数据

Question

我正在尝试构建一个宏来执行以下步骤：

1. 比较两个数据列表（在本例中为A列与C列）



1. 在B中输出A和C中存在的任何单元格。在A列的匹配旁边排列匹配。



1. 按列值对A列和B列进行排序，以便排序后A和B中的相应单元格仍然相邻。



期望的结果。注意A列和B列中的匹配如何仍在一起。这使得该宏的用户能够快速消除仅属于相应列和之一的数据，它允许我们保留可能与列A相关的任何信息，例如，列A包含电子邮件地址，并且旁边有一个包含电话＃的对应列。我们不想将这些信息分开。这个宏将启用：

我使用的Excel数据的Pastebin：http://pastebin.com/mYuQRMjj



这是我写的宏，它使用第二个宏：

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

进行比较的第二个宏直接从微软中删除了一些额外的内容。

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

使用这两个宏，我得到了我想要的，但我不喜欢使用有限的范围。我希望宏足够聪明以确定范围是什么，因为将使用此宏的人有时会使用200的列表，有时候是2,000,000的列表。我希望这个宏是一个适合所有人的＃34;范围。

我调查了这个和命令：

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

在Find_Matches运行后得到我想要的选择（我也意识到Find_Matches正在使用有限的比较范围...解决我的问题，第一个宏也将解决这个问题。）

问题是我不确定如何将其插入我的宏。我已经尝试过多次实施，而且我已经陷入困境。我找不到具体的答案，但我知道我非常接近。谢谢你的帮助！

编辑：整个方法在较大的列表上是 realllly 慢（在100k的列表上超过20分钟）。如果你能提出一些方法来加快它，那将是非常有帮助的！

Answer 1

请参阅Error in finding last used cell in VBA了解查找最后一行数据的最佳方法。

找到最后一行，然后将范围选择更改为：

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

要加快宏执行速度，请使用以下命令启动宏：

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

要恢复autocalc和屏幕更新，请使用以下命令结束宏

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