Comparando dos lists grandes con múltiples columnas (el mismo número en cada list) en excel VBA y haz … más cosas

He buscado por todas partes y no puedo encontrar nada que se ajuste a mis necesidades.

La situación: tengo dos lists de datos con el mismo tipo de datos en cada columna (10 columnas pero las últimas 2 son inútiles), pero las lists son de longitud variable (actualmente 55k en una, 18k en la otra). La list más larga va a ser una list en ejecución de elementos con los datos más actualizados en cada columna para el número de ID único en la columna A. La otra list está vinculada a una list de SharePoint que actualizo un par de veces al día.

La necesidad: necesito que la list que actualiza desde SharePoint se compare con la list en ejecución. Si hay numbers de identificación únicos coincidentes en las lists, entonces la list en ejecución debe actualizarse a los datos extraídos. Si la list de ejecución no contiene una identificación única que está en la list extraída, la nueva línea debe agregarse a la list en ejecución (que se orderará más adelante).

Primero intenté hacer esto con las references de celda en dos loops for y solo 10 filas funcionó bien. Cuando traté de ejecutarlo por cada línea, tuve problemas. Así que traté de usar matrices en su lugar, pero este es un territorio nuevo para mí. El código parece estar funcionando, pero se está tardando mucho time en ejecutarse (lo dejé durante 10 minutos antes de que se detuviera la fuerza). Intenté agregar algunos aumentos de eficiencia, como desactivar la actualización de la pantalla y los cálculos, pero no deberían tener ningún efecto ya que estoy usando matrices y no estoy actualizando las células hasta que la comparación de la matriz haya finalizado. Si las matrices son más eficientes, genial, pero no sé cómo combinar los datos de la matriz de la list extraída con la matriz de la list en ejecución.

Aquí está el código que tengo hasta ahora:

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 

Cualquier dirección sería muy apreciada.

Esto se ejecutó en <1 segundo para mí, utilizando 20k filas "datos", ~ 3k filas "extracción" (mezcla de actualizaciones y nuevas).

EDITAR : arregló y agregó algunos comentarios …

 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 networkingimension 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 

Sería mejor utilizar MSAccess para hacer esto. Vincúlese a ambas tablas y luego realice una combinación interna en el campo de id o cualquier campo que vincule los elementos en las dos lists.