Arrays 在excel VBA中比较两个具有多个列的大型列表（每个列表中的数字相同），然后做更多的事情

我到处找了，找不到适合我需要的东西

情况： 我有两个数据列表，每列中都有相同类型的数据（10列，但最后2列是无用的），但列表的长度不同（其中一列当前为55k，另一列为18k）。较长的列表将是一个项目的运行列表，在a列中的唯一ID的每列中都有最新的数据。另一个列表链接到我每天更新几次的SharePoint列表

需要： 我需要将从SharePoint更新的列表与正在运行的列表进行比较。如果列表中有匹配的唯一ID#，则需要将正在运行的列表更新为拉取的数据。如果运行列表不包含拉入列表中的唯一ID，则需要将新行添加到运行列表中（稍后将对其进行排序）

我第一次尝试在两个for循环中使用单元格引用来实现这一点，但对于10行来说效果很好。当我试着在每条线路上运行它时，我遇到了问题。所以我尝试使用数组，但这对我来说是一个新领域。代码似乎正在运行，但运行起来需要很长时间（在强制停止之前，我让它运行了10分钟）。我尝试过增加一些效率提升，比如关闭屏幕更新和计算，但它们不会有任何效果，因为我使用的是数组，在数组比较完成之前不会实际更新单元格。如果数组效率更高，那就太好了，但我不知道如何将拉入列表的数组中的数据组合到运行列表的数组中

以下是我目前掌握的代码：

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

子数据\u编译\u单元格（）
将sdata标注为工作表，将spull标注为工作表
调暗p为长，d为长，c为长
变暗lrdata为长，lrpull为长
尺寸数据作为范围，R作为范围
将Newvalue设置为布尔值
Dim apull作为变型，adata作为变型
Dim nrows为长，ncols为整数
设置sdata=图纸（“数据”）
设置spull=工作表（“数据拉取”）
Newvalue=“FALSE”
i=1
apull=喷射范围（“A1”）.当前区域
adata=数据范围（“A1”）.当前区域
'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，激活
'******统一身份证******
'从SharePoint中提取的唯一ID的运行列表
对于p=2至UBound（apull，1）
“我试图添加一个状态栏，以查看代码是否正在实际运行
'Application.StatusBar=“Progress:”&p&“of”&UBound（apull，1）和“：”&Format（p/UBound（apull，1），“0%”）
'将每个ID与已列出的唯一ID进行比较
对于d=2至UBound（adata，1）
'检查匹配的唯一ID'
如果adata（d，1）=apull（p，1），那么
'检查行中具有匹配唯一ID的每个单元格
对于c=2到10
'如果单元格没有相同的数据，请将数据数组值替换为拉数组中的值
如果adata（p，c）apull（d，c），那么
adata（d，c）=apull（p，c）
如果结束
下一个c
'如果找到匹配项，请跳到下一个p值
退出
其他的
Newvalue=“TRUE”
'需要代码向数据数组追加新行
如果结束
下一个d
下一个p
“对数据进行排序
'范围（“A2”）.CurrentRegion.Sort键1:=范围（“A2”），顺序1:=xl升序，标题：=xlYes
Application.ScreenUpdating=True
Application.Calculation=xlCalculationAutomatic
端接头

---

任何方向都将不胜感激。

这是在中运行的，您最好使用MSAccess来执行此操作。链接到两个表，然后对id字段或哪个字段链接两个列表中的项目进行内部联接

一个Id是否可以在每个列表中重复多次？如果不是这样，那么如果您为运行列表中的Id列创建一个dictionary对象，将Id映射到行号，代码可能会快得多。然后您可以检查

d.Exists（idValue）

，这比在数组上循环快得多。不，每个ID在每个列表中只出现一次。我将查找有关创建dictionary对象的一些信息。看起来我无法访问脚本包，可能无法访问。我考虑改用集合，但我认为这行不通，因为我需要方便地访问密钥和其他信息。因此，如果您尝试运行此操作，将出现错误

Dim d:Set d=Createobject（“scripting.Dictionary”）

？你在Mac电脑上吗？1）更新或2）新行项目的检查记录的百分比大概是多少？这看起来可以/应该起作用。我第一次尝试运行它时（将mods与实际的工作表名称匹配），我得到了一个类型不匹配，因为并非所有的数据都是字符串类型。我将cstr（arrData（r，1）添加到coll.add命令中。这似乎解决了问题，但现在它捕获的唯一内容是单元格A1。想法？是的-在将Id添加到集合或从“pull”进行比较之前，可能需要使用

cstr（）

强制Id为字符串数据。我的Id碰巧已经是字符串了。你的Id看起来像什么？它们只是数字吗？如果它不起作用，那么在没有看到工作簿的情况下很难说出问题所在。唯一Id的整列都是数字，格式也是这样。我将cstr添加到“tmp=”中同样。仍然只捕获第一个单元格。看起来它在找到第一个匹配项（第一行是标题行）后结束了脚本。我解决了问题。这与将数据放回单元格的方式有关。当使用范围（“A1”）时.CurrentRegion=arrData，excel仅识别当前区域为单元格A1。我将该行更改为“.Range（.Cells（1,1），.Cells（ubD，10））=arrData”，现在它工作得非常好！感谢您提供的惊人修复。我会记住的

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