Question

第一次海报长期读者。

我的同事和我花了一段时间创建这段代码。虽然它对于小数据大小运行非常出色，但我们的完整数据集是两个100k左右的表格。我们让它运行大约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

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

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

1 个答案: