加快排序数组和二分查找

Question

我正在尝试比较两个工作表，它们都有我想要比较的“EMAIL”列。一列包含已发送的电子邮件，另一列包含人们实际点击的电子邮件。

我已将两列定义为数组，EmailList 和 ClickthroughsList，并且对于 EmailList 数组中的每个位置，我都有一个 If 循环循环通过 ClickthroughList 直到找到匹配项：

            For i = 1 To lRow
                EmailList(i) = ThisWorkbook.Sheets(2).Cells(i, col).Value
                Sheets(7).Cells(i, 1).Value = EmailList(i)

                If i = 1 Then
                Sheets(7).Cells(i, 2).Value = "Sent"
                Sheets(7).Cells(i, 5).Value = "Unique Clickthroughs"

                Else
                Sheets(7).Cells(i, 2).Value = 1

                    For bi = 1 To bRow
                    If EmailList(i) = ClickthroughsList(bi) Then
                    Sheets(7).Cells(i, 5).Value = 1
                    End If
                    Next bi

                End If

            Next i

如果找到匹配项，我希望它在 Sheets(7) 上显示“1”，如上所述。这意味着该特定电子邮件已被点击。

当数组为 700k+ 行或以上时，对于两个数组，此代码需要几个小时才能运行。

有人建议我可以先进行排序，然后再进行二进制搜索。但是，我仍然需要数组在 EmailList 中的位置，以便我可以在它旁边放一个“1”（并且该行将包含更多特定于该电子邮件的信息）。

想到的是定义一个新的排序数组，同时保留旧数组，并且当我在新排序数组中找到匹配项时，将其匹配回旧数组以知道位置？

            Option Explicit
            Private wsSent As Worksheet
            Private aCell As Range, Rng As Range
            Private col As Long, lRow As Long
            Private colName As String
            Private i As Long
            Private EmailList() As String

            Private wsClickthroughs As Worksheet
            Private bCell As Range, bRng As Range
            Private bcol As Long, bRow As Long
            Private bcolName As String
            Private bi As Long
            Private ClickthroughsList() As String

            Sub EmailArrayClickthroughs()

            Application.ScreenUpdating = False

            GetClickthroughsArray
                '~~> Change this to the relevant sheet
                Set wsSent = ThisWorkbook.Sheets(2)

                With wsSent
                    Set aCell = .Range("A1:DZ1").Find(What:="EMAIL", LookIn:=xlValues, LookAt:=xlWhole, _
                                MatchCase:=False, SearchFormat:=False)

                    '~~> If Found
                    If Not aCell Is Nothing Then
                        col = aCell.Column
                        colName = Split(.Cells(, col).Address, "$")(1)
                        lRow = .Range(colName & .Rows.Count).End(xlUp).Row
                    '~~> This is your range
                        Set Rng = .Range(colName & "2:" & colName & lRow)

                    Else
                        MsgBox "EMAIL (Clickthroughs) Not Found"
                    End If
                End With

            ReDim EmailList(lRow)

            For i = 1 To lRow
                EmailList(i) = ThisWorkbook.Sheets(2).Cells(i, col).Value
                Sheets(7).Cells(i, 1).Value = EmailList(i)

                If i = 1 Then
                Sheets(7).Cells(i, 2).Value = "Sent"
                Sheets(7).Cells(i, 5).Value = "Unique Clickthroughs"

                Else
                Sheets(7).Cells(i, 2).Value = 1

                    For bi = 1 To bRow
                    If EmailList(i) = ClickthroughsList(bi) Then
                    Sheets(7).Cells(i, 5).Value = 1
                    End If
                    Next bi

                End If

            Next i

            Debug.Print Rng.Address

            Application.ScreenUpdating = True

            End Sub


            Sub GetClickthroughsArray()

                '~~> Change this to the relevant sheet
                Set wsClickthroughs = ThisWorkbook.Sheets(5)

                With wsClickthroughs
                    Set bCell = .Range("A1:DZ1").Find(What:="EMAIL", LookIn:=xlValues, LookAt:=xlWhole, _
                                MatchCase:=False, SearchFormat:=False)

                    '~~> If Found
                    If Not bCell Is Nothing Then
                        bcol = bCell.Column
                        bcolName = Split(.Cells(, bcol).Address, "$")(1)
                        bRow = .Range(bcolName & .Rows.Count).End(xlUp).Row
             '~~> This is your range
                        Set bRng = .Range(bcolName & "2:" & bcolName & bRow)
                    Else
                        MsgBox "EMAIL (opens) Not Found"
                    End If
                End With

            Debug.Print bRng.Address

            ReDim ClickthroughsList(bRow)

            For bi = 1 To bRow
                ClickthroughsList(bi) = ThisWorkbook.Sheets(5).Cells(bi, bcol).Value
            Next bi

            End Sub

Answer 1

如果我了解您要执行的操作，则无需使用 VBA。

只需使用 MATCH 工作表功能。在要查看值是否在“ClickThrough”表中的列中，放入

 =IF(ISNA(MATCH(colEmail, YourSheet!colEmail1:colEmail1000, 0)), "0", "1")

YourSheet 必须是带有点击电子邮件的工作表名称。 colEmail 需要是包含您要查找的“电子邮件”的任何列，并且 1000 是记录数。您可以改为只输入“A：A”来获取整个列。

最后它看起来像这样：

= IF(IF(ISNA(MATCH(A2, mySheet!$A$2:$A$1000, 0)), "0", "1")

然后将其复制到整个列。

Answer 2

好的，这是一个相当简单的修复。您可以在 VBA 中为性能做的最糟糕的事情是循环单元格。要解决此问题，请创建一个变量范围并将列表分配给它。即使有 700K 行，在单个命令中将两个列表分配给一个变量也应该花费不到一秒的时间。然后在比较它们时，您会喜欢在不到 30 秒的时间内进行比较。如果您需要根据比较的结果写回行，请创建一个大小相同的变量，然后将您想要写入的任何内容写入该变量。然后在一切完成后，通过循环或范围粘贴将该变量转储到电子表格中。我猜您可以轻松地将其缩短到 2 分钟以下。 Make it faster?

Answer 3

这是匹配两个列表的一种方法：

Sub TestMatch()

    Dim rng1 As Range, rng2 As Range, f

    Set rng1 = Range("C3:C22")
    Set rng2 = Range("F3:F19")

    f = "=IFERROR(MATCH(" & rng1.Address(False, False) & _
      "," & rng2.Address(True, True) & ",0),0)>0"

    Debug.Print f

    rng1.Offset(0, 1).Value = ActiveSheet.Evaluate(f)

End Sub

...而且这个更快（

Sub TestMatch2()

    Dim d, arr1, arr2, r
    Set d = CreateObject("scripting.dictionary")

    'get the data in arrays
    arr1 = Range("A1:A700000").Value
    arr2 = Range("E1:E7000").Value

    'put the smaller list in the dictionary
    For r = 1 To UBound(arr2, 1)
        If Not d.exists(arr2(r, 1)) Then d.Add arr2(r, 1), 1
    Next r

    'check the larger list against the dictionary,
    '   modifiying the array as we go
    For r = 1 To UBound(arr1, 1)
        arr1(r, 1) = IIf(d.exists(arr1(r, 1)), 1, "")
    Next r
    'populate the result column
    Range("A1:A700000").Offset(0, 1).Value = arr1

End Sub