在Excel VBA中将两个大列表与多个列（每个列表中的相同编号）进行比较，然后执行…更多内容
我已经search了很多，我不能find任何适合我的需求。
情况：我有两列相同types的数据（每列10列，但最后2列是无用的），但列表长度不同（目前55k一个，其他18k）。 较长的列表将成为A列中唯一ID＃的每列最新数据的运行列表。另一列表链接到每天更新几次的SharePoint列表。
需要：我需要从SharePoint更新的列表与运行列表进行比较。 如果列表中存在匹配的唯一ID号，则运行列表需要更新为已提取的数据。 如果运行列表中不包含处于拉出列表中的唯一标识，则需要将新行添加到正在运行的列表中（稍后将对其进行sorting）。
我第一次尝试使用单元格引用中的两个for循环和只有10行这工作正常。 当我尝试运行它的每一行，我有问题。 所以我尝试使用数组，但这是我的新领域。 代码似乎在工作，但需要很长时间才能运行（在停止之前我已经放了10分钟）。 我尝试添加一些效率增加，如closures屏幕更新和计算，但他们不应该有任何效果，因为我使用数组，而不是实际更新单元格，直到数组比较完成。 如果数组更高效，那么很好，但我不知道如何将拉列表数组中的数据合并到运行列表的数组中。
这是我迄今为止的代码：
Sub Data_Compile_Cells() Dim sdata As Worksheet, spull As Worksheet Dim p As Long, d As Long, c As Long Dim lrdata As Long, lrpull As Long Dim rdata As Range, rpull As Range Dim Newvalue As Boolean Dim apull As Variant, adata As Variant Dim nrows As Long, ncols As Integer Set sdata = Sheets("Data") Set spull = Sheets("Data Pull") Newvalue = "FALSE" i = 1 apull = spull.Range("A1").CurrentRegion adata = sdata.Range("A1").CurrentRegion 'lrdata = sdata.Range("A" & Rows.Count).End(xlUp).Row 'lrpull = spull.Range("A" & Rows.Count).End(xlUp).Row Application.Calculation = xlCalculationManual Application.ScreenUpdating = False sdata.Activate '*****UniqueID Check****** 'Run through list of Unique ID's pulled from SharePoint For p = 2 To UBound(apull, 1) 'I tried to add a status bar to see if the code was actually running 'Application.StatusBar = "Progress: " & p & " of " & UBound(apull, 1) & " : " & Format(p / UBound(apull, 1), "0%") 'Compare each one to the Unique ID's already listed For d = 2 To UBound(adata, 1) 'Check for matching Unique ID's If adata(d, 1) = apull(p, 1) Then 'Check each cell in the row with the matching Unique ID For c = 2 To 10 'If a cell does not have the same data, replace the Data array value with the value from the Pull array If adata(p, c) <> apull(d, c) Then adata(d, c) = apull(p, c) End If Next c 'If a match is found, skip to the next p value Exit For Else Newvalue = "TRUE" 'Need code to append new line to Data array End If Next d Next p 'Sort the data 'Range("A2").CurrentRegion.Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub 任何方向将不胜感激。
使用20k行“data”，〜3k rows“pull”（更新和新的混合），这对我来说在<1秒内运行。
编辑 ：收拾起来，并添加一些评论…
Sub tester() Const NUM_NEW As Long = 20000 'large enough ? Dim arrPull, arrData, arrDataId, arrNew() Dim ubP As Long, ubD As Long Dim numNew As Long, r As Long Dim v, c As Long Dim t, tmp, coll As Collection t = Timer 'grab the current and new data arrPull = Sheets("Pull").Range("A1").CurrentRegion.Value arrData = Sheets("Data").Range("A1").CurrentRegion.Value ubP = UBound(arrPull, 1) ubD = UBound(arrData, 1) numNew = 0 ReDim arrNew(1 To NUM_NEW, 1 To 10) 'array for new data 'create a collection to map ID to "row number" Set coll = New Collection For r = 1 To ubD coll.Add Item:=r, Key:=arrData(r, 1) Next r For r = 1 To ubP tmp = arrPull(r, 1) v = 0 'collection has no "exists" function, so trap any error On Error Resume Next v = coll.Item(tmp) On Error GoTo 0 If v > 0 Then 'Id already exists: update data For c = 2 To 10 arrData(v, c) = arrPull(r, c) Next c Else 'new Id: add to the "new" array numNew = numNew + 1 If numNew > NUM_NEW Then MsgBox "Need larger `new` array!" 'a more sophisticated approach would be to dump the full ' array to the sheet and then redimension it for more ' data... Exit Sub End If For c = 1 To 10 arrNew(numNew, c) = arrPull(r, c) Next c End If Next r 'drop updated and new (if any) to the worksheet With Sheets("Data") .Range("A1").CurrentRegion.Value = arrData If numNew > 0 Then .Cells(ubD + 1, 1).Resize(numNew, 10).Value = arrNew End If End With Debug.Print "Done in " & Timer - t & " sec" End Sub
你最好使用MSAccess来做到这一点。 链接到两个表，然后在id字段上进行内部联接，或者在哪个字段中链接两个列表中的项目。