优化代码在2张纸上匹配2个值

Question

我在Sheet1上有一个客户列表，在Sheet2上有原始数据。有40多个用户组，我想知道是否有比为每个组设置For更有效的方法来处理这个问题。

客户列表位于C行。例如，A组来自C2:C25，B组来自C26:C89，C组来自C90:C116，等等。

此代码的目标是确定是否有任何客户端组在Sheet2上的原始数据中(A列中超过14k行)，并显示pref。只有一个MsgBox，它们就是。

Sub shomedawau()
Dim FindString As String
Dim Rng As Range

For Each Cell In Sheets("Sheet1").Range("C2:C32")
    FindString = Cell.Value

    If Trim(FindString) <> "" Then
        With Sheets("Sheet2").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                MsgBox "group A found"
            End If
        End With
    End If
Next

For Each Cell In Sheets("Sheet1").Range("C33")
    FindString = Cell.Value

    If Trim(FindString) <> "" Then
        With Sheets("Sheet2").Range("A:A")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                MsgBox "group B found"
            End If
        End With
    End If
Next

End Sub

Answer 1

实际上，您的代码应该运行得非常快。但是，如果您忽略范围并开始处理数组，则存在一个优化的位置：

Public Sub TestMe()

    Dim r1      As Variant
    Dim r2      As Variant
    Dim r       As Variant
    Dim result  As Variant

    r1 = Application.Transpose(Worksheets(1).Range("C1:C10"))
    r2 = Application.Transpose(Worksheets(2).Range("A:A")) 'up to 65536th row!

    For Each r In r1
        result = Application.Match(r, r2, 0)
        If Not IsError(result) Then
            Debug.Print r & " is found!"
        End If
    Next r

End Sub

代码只读取两个范围一次，然后在VBA环境中操作，这大大加快了速度。

MSDN WorksheetFunciton.Match

Answer 2

请试试这个密码。但是，在检查顶部的枚举之前。这是您可以确定哪一列是哪一页的地方。根据需要进行更改。而且，在任何过程之前，Enums必须位于代码表的顶部。

您还需要更改两个工作表的名称。我称之为"RawData“和”组“。将这些名称替换为工作簿中的名称。

最后，我假定组名(我必须假定它们在B列(更改枚举以匹配事实)位于合并的单元格中。如果它们不起作用，代码就无法工作。(必要时可进行调整。)如果RawData!A1是水平合并的单元格，它也将无法工作。

Option Explicit

Enum Nsg                        ' Sheet "Groups"
    ' 25 Jan 2018
    NsgFirstDataRow = 2
    NsgGroup = 2                ' 2 = column B
    NsgCustom
End Enum

Enum Nsd                        ' Sheet "Data"
    ' 25 Jan 2018
    NsdFirstDataRow = 2
    NsdCustom = 1               ' 1 = column A
End Enum


Sub FindGroups()
    ' 25 Jan 2018

    Dim Msg As String
    Dim Spike As String                         ' result collector
    Dim ArrCustom As Variant
    Dim SearchRng As Range
    Dim R As Long, Rstart As Long, Rend As Long
    Dim Rc As Long                              ' Customers

    With Worksheets("RawData")
        R = .Cells(.Rows.Count, NsdCustom).End(xlUp).Row
        Set SearchRng = Range(.Cells(NsdFirstDataRow, NsdCustom), _
                              .Cells(R, NsdCustom))
    End With

    With Worksheets("Groups")
        ArrCustom = Range(.Cells(1, NsgCustom), _
                          .Cells(.Rows.Count, NsgCustom).End(xlUp))
        R = NsgFirstDataRow
        Do While R <= UBound(ArrCustom)
            Rstart = R
            Rend = Rstart + .Cells(R, NsgGroup).MergeArea.Rows.Count - 1
            R = Rend + 1
            For Rc = Rstart To Rend
                If FindCustomer(ArrCustom(Rc, 1), SearchRng) Then
                    Spike = Spike & Chr(13) & .Cells(Rstart, NsgGroup).Value
                    Exit For
                End If
            Next Rc
        Loop
    End With

    Msg = IIf(Len(Spike), "The following", "No")
    MsgBox Msg & " groups were found in the raw data." & Spike, _
           vbInformation, "Search report"
End Sub

Private Function FindCustomer(ByVal Custom As String, _
                              SearchRng As Range) As Boolean
    ' 25 Jan 2018

    Dim Fnd As Range

    With SearchRng
        Set Fnd = .Find(What:=Custom, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
    End With
    FindCustomer = Not (Fnd Is Nothing)
End Function