VBA-Excel查找查找两周日期范围和此范围内的第一个帐户ID

Question

第一次海报长期阅读。

我和我的同事花了一段时间来创建这段代码。虽然它适用于小数据量，但我们的完整数据集是两个 10 万行左右的表。我们让它运行了大约 30-40 分钟，然后它就停止了。我们不知道如何让它更快。

这个想法是，对于一个表中的每一行，我们需要在第二个表中搜索最接近帐户日期前两天的日期。我们还找到了距两天前的日期最接近 2 周的日期。日期按从上到下从新到旧排序。

一旦我们有了这个范围，我们需要搜索另一列来找到出现在这个日期范围内的第一个帐户 ID。一旦我们知道了这一行，我们就可以用它来查找该行中的另外两个单元格。

我想以某种方式在数组中执行它会更好，但我不知道如何让它达到我们所追求的水平。可能将所有日期粘贴在一个数组中并计算出数组编号并将其用于稍后查找的行？

到目前为止，这是我们的代码。我知道我们的第一个问题可能是因为我们有一个循环遍历一个表并将帐号和日期输入到执行工作的函数中：

Function Find_Last(AccountNumber, AccountDate As Date)
'Function to find the first occurance of account number and associated quality within a two week range

Dim R As Range
Dim LastDiff1 As Date
Dim LastDiff2 As Date
Dim LastCell1 As Range, LastCell2 As Range
Dim SearchDate1
Dim SearchDate2
Dim Rng As Range
Dim DestSheet As Worksheet
Dim LastRow

Set DestSheet = Workbooks("Interim Referrals Report.xlsm").Worksheets("SA Wrap Up Data")

SearchDate1 = DateAdd("d", 14, AccountDate)
SearchDate2 = DateAdd("d", -2, AccountDate)

LastDiff1 = DateSerial(9999, 1, 1)
LastDiff2 = DateSerial(9999, 1, 1)

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For Each R In DestSheet.Range("A2:A" & LastRow)
    If IsDate(R.Value) Then
        'Do Nothing
        If Abs(R.Value - SearchDate1) < LastDiff1 Then
            Set LastCell1 = R
            LastDiff1 = Abs(R.Value - SearchDate1)
        End If
    End If
    If IsDate(R.Value) Then
        'Do Nothing
        If Abs(R.Value - SearchDate2) < LastDiff2 Then
            Set LastCell2 = R
            LastDiff2 = Abs(R.Value - SearchDate2)
        End If
    End If
Next R


'Find the CR account number within the designated range in the SA cricket
'data worksheet, looks from bottom of range up
With DestSheet.Range("L" & LastCell1.Row & ":L" & LastCell2.Row)
    Set Rng = DestSheet.Cells.Find(What:=AccountNumber, After:=.Cells(LastCell1.Row), LookIn:=xlFormulas, LookAt:=xlWhole, _
    SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
       'if there is a match, return the row number
        If Not Rng Is Nothing Then
            Find_Last = Rng.Row
        Else
            Find_Last = "No Match"
        End If
End With

End Function

谁能帮忙？

Answer 1

您说得对，将循环更改为使用数组将比循环范围快很多。

这是使用Variant Array 的循环版本。未经测试，但应该接近...

Dim Dat As Variant
Dim idx As Long
Dim idxLastCell1 As Long
Dim idxLastCell2 As Long

With DestSheet
    ' start array at row 1 to avoid confusing index offset
    Dat = .Range("A1:A" & LastRow).Value
    idxLastDiff1 = 2
    idxLastDiff2 = 2

    ' Loop from row 2
    For idx = 2 To UBound(Dat, 1)
        If IsDate(Dat(idx, 1)) Then
            If Abs(Dat(idx, 1) - SearchDate1) < Dat(idxLastDiff1, 1) Then
                idxLastCell1 = idx
                LastDiff1 = Abs(Dat(idx, 1) - SearchDate1)
            End If
            If Abs(Dat(idx, 1) - SearchDate2) < Dat(idxLastDiff2, 1) Then
                idxLastCell2 = idx
                LastDiff2 = Abs(Dat(idx, 1) - SearchDate2)
            End If
        End If
    Next
    Set LastCell1 = .Cells(idxLastCell1, 1)
    Set LastCell2 = .Cells(idxLastCell2, 1)
End With

只需将此代码替换为现有循环即可。它设置了您稍后在代码中使用的相同变量。