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

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 

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