VBA-Excel查找在此范围内查找两周的date范围和第一个帐户ID
第一次海报长时间读者。
我的同事和我花了一段时间来创build这个代码。 虽然它在小数据量下运行良好，但是我们的完整数据集是两个10万行左右的表格。 我们让它跑了30-40分钟，然后就停下来。 我们不知道如何让它更快。
我们的想法是，对于一个表中的每一行，我们都需要在第二个表中search最接近帐户date前两天的date。 我们还会在两天之前find最接近2周的date。 date从上到下按最新到最旧sorting。
一旦我们有这个范围，我们需要search另一列来find在这个date范围内出现的第一个帐户ID。 一旦我们知道这一行，我们就用它来查找行中的另外两个单元格。
我想不pipe怎么样，在一个数组里面做会更好，但我不知道如何达到这个水平。 有可能把所有的date都放在一个数组中，并找出数组的数目，然后将这些数据用于后续的查找。
这是我们的代码到目前为止。 我知道我们的第一个问题可能是因为我们有一个循环遍历一个表，并将帐号和date提供给执行工作的函数：
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 谁能帮忙？
你是对的，改变循环使用数组将比循环范围快得多。
以下是使用Variant Array循环版本。 未经testing，但应该接近…
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
用这个代码简单地replace你现有的循环。 它设置了稍后在代码中使用的相同variables。