I have created below piece of code in order to amend some data in an Access table:
Dim Ways As DAO.Recordset
Dim Keys As DAO.Recordset
Dim Recordcount As Double
Dim Records As Double
Dim ID_Old As String
Dim ID_New As String
Dim STArray() As String
Dim SaveTime As String
Set Ways = CurrentDb.OpenRecordset("Ways_Sorted")
Recordcount = 1
Records = 3724755
Ways.MoveFirst
Dim word As Variant
While Not Ways.EOF
DoCmd.SetWarnings (False)
DoCmd.OpenQuery "KeyFind:DEL"
DoCmd.SetWarnings (True)
Set Keys = CurrentDb.OpenRecordset("KeyFind")
STArray = Split(Ways!Veld4, ";")
For Each word In STArray
If Len(word) > 0 Then
Keys.AddNew
Keys!IDOld = CDbl(word)
Keys!IDNew = DLookup("[New ID]", "ID Keys", "[Old ID]=" & CDbl(word))
Keys.Update
End If
Next
Keys.MoveFirst
While Not Keys.EOF
ID_Old = " " + Trim(Str$(Keys!IDOld))
ID_New = " " + Trim(Str$(Keys!IDNew))
Ways.Edit
Ways!Veld4 = Replace(Ways!Veld4, ID_Old, ID_New)
Keys.MoveNext
Wend
Keys.Close
Me.Tekst1 = Recordcount
Me.Tekst3 = Records - Recordcount
Me.Tekst5 = FileLen(Application.CurrentProject.Path & "\Map_Convert_2.mdb")
If FileLen(Application.CurrentProject.Path & "\Map_Convert_2.mdb") > 1977142784 Then
' Exit Sub
End If
DoEvents
Ways!Done = True
Ways.Update
Ways.MoveNext
Recordcount = Recordcount + 1
'CommandBars("Menu Bar").Controls("Tools").Controls("Database utilities").Controls("Compact and repair database...").accDoDefaultAction
'Stop
Wend
DoCmd.SetWarnings (False)
DoCmd.OpenQuery "Ways_Amend ID"
DoCmd.SetWarnings (True)
MsgBox "New Map created"
Actually what the code is doing is replacing the data in field "Veld4" in table "Ways_Sorted". This field holds a string with ID's, which is splitted with STArray = Split(Ways!Veld4, ";") into an array.
This array is stored in a table called "KeysFound".
Another table in my database is containing the old ID and the new ID.
As said the rest of the code will replace the old id in "Veld4"with the new ID.
It is looping through 3.7 million records this way.
My problem is that after 250 loops or so my database has grown with 1mB, meaning that my database will be above the 2gB way before the code has finished.
I can not explain why the growth is happening and how I can stop this or at leas reduce the growth
Your code has lots of potential for optimization.
Main issue: you are constantly writing into and deleting from the Keys table. I guess this is also the cause of the growth issue.
This table is unnecessary. Just do the replacement right after reading each key. Build the new Veld4 as string NewVeld, only write it into the table once you are finished for the current Ways row.
STArray = Split(Ways!Veld4, ";")
NewVeld = ""
For Each word In STArray
If Len(word) > 0 Then
NewKey = DLookup("[New ID]", "ID Keys", "[Old ID]=" & CDbl(word))
' you will have to adapt this to your exact "veld" structure
' If there is a specific reason, you can also continue to use Replace(),
' but I don't think it's necessary.
NewVeld = NewVeld & ";" & NewKey
End If
Next
' remove leading ";"
NewVeld = Mid(NewVeld, 2)
Ways.Edit
Ways!Veld4 = NewVeld
Ways!Done = True
Ways.Update
Ways.MoveNext
Further optimization: DLookup is a rather expensive operation for your row count.
Consider loading the whole ID Keys table into a Dictionary object at the beginning, then reading the new IDs from there.
Related
I have quite a conundrum which I have been trying to troubleshoot. I have a stored procedure in a MySql database, which I call through an Excel VBA application. The VBA application passes the recordset into an Array, and then I use a For Loop to place each of the items in the Array onto a worksheet.
Here's the problem: two of the values in the recordset keep coming back blank in Excel. Oddly, the two are in the middle of the Array, not the beginning or end. However, if I call the stored procedure through another query program such as HeidiSql, I receive ALL values back. I'm at a loss as to why I'm not receiving all of the values through Excel... or why the Array isn't receiving them all, at any rate.
Thanks in advance for your help.
Here is my code:
Sub StartHereFlexFunderCust()
On Error GoTo ErrorHandler
Dim Password As String
Dim SQLStr As String
'OMIT Dim Cn statement. Cn stands for Database Connection
Dim Server_Name As String
Dim User_ID As String
Dim Database_Name As String
Dim custID As String
Dim myArray()
'OMIT Dim rs statement. rs stands for Database Recordset and is the Recordset of what is returned
Set RS = CreateObject("ADODB.Recordset")
Server_Name = Range("O10").Value
Database_Name = Range("O11").Value ' Name of database
'id user or username. We need to write code to insert the current user into this variable (Application.Username) if possible. But they may not be consistent across all machines.
'For example mine is "Ryan Willging" and we would have to shorten it to rwillging but others may be rwillging.
'This is important because if we do not do this all queries will come from the same person and that is not good for debugging.
User_ID = Range("O12").Value
Password = Range("O13").Value
custID = Range("C4").Value 'Deal Number from Start here that we are passing into the stored procedure
'This is the storedprocedure call and it passes in the value of the DealId to the Stored Procedure
SQLStr = "call flexFundByCustomer(" + custID + ")"
Set cn = CreateObject("ADODB.Connection") 'NEW STATEMENT
'This statement takes the variables from the checklist and passes them into a connection string
cn.Open "Driver={MySQL ODBC 5.1 Driver};Server=" & _
Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
'This statement queries the database using the SQL string and the connection string.
'The adOpenStatic variable returns a static copy of a set of records that you can use to find data or generate reports. There are other variables that
'could be used but I think this one will suffice.
RS.Open SQLStr, cn, adOpenForwardOnly
Debug.Print msg 'or MsgBox msg
'Take all of the info from the queries and put them into the spreadsheet
myArray = RS.getrows()
Dim Fld_Name As String
Dim Val_of_Field As String
Dim starthere As Worksheet
Fld_Name = UBound(myArray, 1)
Val_of_Field = UBound(myArray, 2)
Set starthere = ThisWorkbook.Sheets("Start Here")
MsgBox "No error yet defined Start Here!"
'This little loop works well to dump the recordset into excel. We can then map the correct fields 'k inputs the headers and R inputs the rows returned in the Recordset
For K = 0 To Fld_Name ' By using a For loop the data is inputed into excel one row at a time
starthere.Range("U4").Offset(0, K).Value = RS.fields(K).Name
For R = 0 To Val_of_Field
starthere.Range("U4").Offset(R + 1, K).Value = myArray(K, R)
Next
Next
RS.Close
Set RS = Nothing
cn.Close
Set cn = Nothing
ErrorHandler:
MsgBox "There's been an error!"
Exit Sub
End Sub
Consider using Range.CopyFromRecordset method to avoid any use of arrays. Or if memory does not allow, use a Do While Loop across Recordset columns:
' COLUMN HEADERS
For i = 1 To RS.Fields.Count
starthere.("Results").Range("U4").Offset(0, i) = RS.Fields(i - 1).Name
Next i
' DATA ROWS
' COPYFROMRECORDSET APPROACH
starthere.Range("U5").CopyFromRecordset RS
' DO WHILE LOOP APPROACH
starthere.Activate
starthere.Range("U5").Activate
row = 5
Do While Not RS.EOF
For i = 0 To RS.Fields.Count - 1
ActiveCell.Offset(0, i) = RS.Fields(i)
Next i
row = row + 1
ActiveCell.Offset(row, 21)
RS.MoveNext
Loop
As for the values returning empty that may be a MySQL and Excel incompatibility of data types. For instance, you may have a table field set to MySQL's maximum decimal (65, 30) which denotes max digits of 65 and max 30 decimal points which cannot be reflected on a spreadsheet. Current precision limit of a cell value is 15 decimal points.
Alternatively, you may have a VARCHAR(65535) which is the 65,535 byte limit or the open-ended TEXT column of no limit that also cannot be displayed on spreadsheet. Current limit of characters in one cell is 32,767.
Try modifiying column to a smaller type:
ALTER TABLE `tableName` MODIFY COLUMN `largenumberfield` DECIMAL(10,7);
ALTER TABLE `tableName` MODIFY COLUMN `largetextfield` VARCHAR(255);
Why the other programs such as HeidiSQL retrieve values? It might be due to their internal conversion features forcing data values into a specific format (i.e., removing whitespaces, truncating values) which then renders adequately in Excel.
I am creating a simple spreadsheet which takes an array of IDs from worksheet "input", queries an Oracle database asking for only the records which match the IDs in the array and outputs the results to worksheet "output".
So far, my VBA will work if my array only contains a single ID (by specifying a single cell range), and everything completes with the desired output from the Oracle database appearing in worksheet "output". Good times.
The problem I am having now is that I want to specify a range of IDs (anything up to around 5000) in worksheet "input" to include in my array and pass that array to the Oracle database to return data for each ID it finds (I am not expecting all IDs to exist). Whenever I try this I seem to get "Error 13 Type Mismatch" errors... Bad times.
My VBA code is:
Dim OracleConnection As ADODB.Connection
Dim MosaicRecordSet As ADODB.RecordSet
Dim SQLQuery As String
Dim DBConnect As String
Dim count As String
Dim strbody As String
Dim Exclude As String
Dim i As Integer
Dim Rec As RecordSet
Dim InputIDs As Variant
Set OracleConnection = New ADODB.Connection
DBConnect = "Provider=msdaora;Data Source=MOSREP;User ID=***;Password=***;"
OracleConnection.Open DBConnect
' Clear Output Sheet Down
Sheets("Output").Select
Range("A2:F10000").Clear
' Set Input Range
Sheets("Input").Columns("A:A").NumberFormat = "0"
InputIDs = Sheets("Input").Range("A2:A10").Value
' SQL Query
SQLQuery = "select DMP.PERSON_ID, DMP.FULL_NAME, DMP.DATE_OF_BIRTH, DMA.ADDRESS, DMA.ADDRESS_TYPE, DMA.IS_DISPLAY_ADDRESS " & _
"from DM_PERSONS DMP " & _
"join DM_ADDRESSES DMA " & _
"on DMA.PERSON_ID=DMP.PERSON_ID " & _
"where DMP.PERSON_ID in (" & InputIDs & ")"
Set MosaicRecordSet = OracleConnection.Execute(SQLQuery)
Sheets("Output").Range("A2").CopyFromRecordset MosaicRecordSet
' Change DOB Format
Sheets("Output").Columns("C:C").NumberFormat = "dd/mm/yyyy"
' Set Left Alignment
Sheets("Output").Columns("A:Z").HorizontalAlignment = xlHAlignLeft
Range("A1").Select
OracleConnection.Close
Set MosaicRecordSet = Nothing
Set OracleConnection = Nothing
ActiveWorkbook.Save
Can anyone shed light on what I am missing? I have attempted to resolve the Type Mismatch issue by setting the 'numberformat' on the column in worksheet "input" to "0" but that didn't help. I also thought that I might have to have a loop to iterate through each record, but I haven't got to that stage yet because of this Type Mismatch thing...
Thank you everyone for your help in advance!
Regards
Matt
The ID's need to be comma delimited
InputIDs = getIDs( Sheets("Input").Range("A2:A10") )
Function getIDs(rng As Range)
Dim c As Range
Dim s As String
For Each c In rng
s = s & c.Value & ","
Next
getIDs = Left(s, Len(s) - 1)
End Function
I have an Access database with about 500,000 records. There is a specific column which has the transaction reference.
This is of the form:
Transaction_Ref
CDY1053N1
CDY1053N2
CDY1053N3
JFD215D1
JFD215D2
Where CDY1053N and JFD215D are customer references, and the 1,2,3, etc which follows is the transaction number.
What I am looking for is a loop which will update a column called "Group". This will go to row 1, and loop through the database to find transaction references similar to CDY1053N and assign a group ID, for example:
Transaction_Ref Group_ID
CDY1053N1 1
CDY1053N2 1
CDY1053N3 1
JFD215D1 2
JFD215D2 2
Any ideas please?
Thanks for the help.
This might not be the best or most elegant way to do this (particularly with the number of records you have), but this worked on my small set of test records.
I've assumed Transaction_Ref and Group_ID are in the same table and I've called that table tblTransactions.
I've also assumed that you might want to run this on new data so have nulled the Group_ID before looping through and resetting the values. This could mean that a different value for Group_ID gets assigned for a group of records (for example, were your records change order between subsequent runs of this sub).
If that's a problem you'll need to tweak this a bit.
Public Sub AssignGroupID()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String
Dim i As Integer
Set db = CurrentDb
' Clear the Group_ID column (in case you want to run this more than once)
sql = "UPDATE tblTransactions Set Group_ID = Null"
db.Execute sql
' Open your table with the Transaction_Ref and Group_ID fields
Set rs = db.OpenRecordset("tblTransactions")
' Zero the counter
i = 0
' Start the loop (set it to end when it gets to the last record)
Do While Not rs.EOF
' Only update Group_IDs that haven't got a value yet
If IsNull(rs!Group_ID) Then
' Push the counter on
i = i + 1
' Update all Group_IDs with current counter number that
' match the customer reference of the current record
sql = "UPDATE tbltransactions Set Group_ID = " & i & " WHERE " _
& "Left(tblTransactions.Transaction_Ref, Len(tblTransactions.Transaction_Ref) -1) = '" _
& Left(rs!Transaction_Ref, Len(rs!Transaction_Ref) - 1) & "'"
db.Execute sql
End If
' Move to the next record
rs.MoveNext
Loop
'clean up
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
I have old .mdb database with a lot of tables/forms/queries and external connections (was created in Access 2003) with User Level security.
Now I have decided to move to SQL Server, but I can't decrypt database (in Access 2010 & 2013) to use with Access to SQL tool.
Decryption process is working but in the end I get an error: "you can't access this table".
I've tried repair & compress.
Can you help me?
Thank you.
You don't have a lot of choices as far as I know:
you can reconstruct the .mdw file by creating a new database and using the exact same username and PID of the original user, then use the new .mdw with the old database.
You can use some of the tools from Serge Gavrilov to help you find the username and PID from a database.
Have a look at the forums on UtterAccess.com. There seem to be a lot of discussions regarding lost mdw.
you can use some data repair services like at EverythingAccess. Cost some money, but I'm sure they can recover your data.
Once you can access the DB, you can write code to extract all the forms, queries and such from the DB. Here's a snippet of code I wrote that does this. You're going to need to tweak it heavily, because it's based on a form that allows you to choose the database name. You're going to have to repeat this for queries, forms, etc...
' Database.
Dim dbRep As DAO.Database
Dim dbNew As DAO.Database
' For copying tables and indexes.
Dim tblRep As DAO.TableDef
Dim tblNew As DAO.TableDef
Dim fldRep As DAO.Field
Dim fldNew As DAO.Field
Dim idxRep As DAO.Index
Dim idxNew As DAO.Index
' For copying data.
Dim rstRep As DAO.Recordset
Dim rstNew As DAO.Recordset
Dim rec1 As DAO.Recordset
Dim rec2 As Recordset
Dim intC As Integer
' For copying table relationships.
Dim relRep As DAO.Relation
Dim relNew As DAO.Relation
' For copying queries.
Dim qryRep As DAO.QueryDef
Dim qryNew As DAO.QueryDef
' For copying startup options.
Dim avarSUOpt
Dim strSUOpt As String
Dim varValue
Dim varType
Dim prpRep As DAO.Property
Dim prpNew As DAO.Property
' For importing forms, reports, modules, and macros.
Dim appNew As New Access.Application
Dim doc As DAO.Document
' Open the database, not in exclusive mode.
Set dbRep = OpenDatabase(Forms!CMDB_frmUpgrade.TxtDatabase, False)
' Open the new database
Set dbNew = CurrentDb
DoEvents
' Turn on the hourglass.
DoCmd.Hourglass True
'********************
Debug.Print "Copy Tables"
'********************
If Forms!CMDB_frmUpgrade.CkTables = True Then
Forms!CMDB_frmUpgrade.LstMessages.addItem "Copying Tables:"
' Loop through the collection of table definitions.
For Each tblRep In dbRep.TableDefs
Set rec1 = dbRep.OpenRecordset("SELECT MSysObjects.Name FROM MsysObjects WHERE ([Name] = '" & tblRep.Name & "') AND ((MSysObjects.Type)=4 or (MSysObjects.Type)=6)")
If rec1.EOF Then
XF = 0
Else
XF = 1
End If
' Ignore system tables and CMDB tables.
If InStr(1, tblRep.Name, "MSys", vbTextCompare) = 0 And _
InStr(1, tblRep.Name, "CMDB", vbTextCompare) = 0 And _
XF = 0 Then
'***** Table definition
' Create a table definition with the same name.
Set tblNew = dbNew.CreateTableDef(tblRep.Name)
Forms!CMDB_frmUpgrade.LstMessages.addItem "--> " & tblRep.Name & ""
' Set properties.
tblNew.ValidationRule = tblRep.ValidationRule
tblNew.ValidationText = tblRep.ValidationText
' Loop through the collection of fields in the table.
For Each fldRep In tblRep.Fields
' Ignore replication-related fields:
' Gen_XXX, s_ColLineage, s_Generation, s_GUID, s_Lineage
If InStr(1, fldRep.Name, "s_", vbTextCompare) = 0 And _
InStr(1, fldRep.Name, "Gen_", vbTextCompare) = 0 Then
'***** Field definition
Set fldNew = tblNew.CreateField(fldRep.Name, fldRep.Type, _
fldRep.Size)
' Set properties.
On Error Resume Next
fldNew.Attributes = fldRep.Attributes
fldNew.AllowZeroLength = fldRep.AllowZeroLength
fldNew.DefaultValue = fldRep.DefaultValue
fldNew.Required = fldRep.Required
fldNew.Size = fldRep.Size
' Append the field.
tblNew.Fields.Append fldNew
'On Error GoTo Err_NewShell
End If
Next fldRep
'***** Index definition
' Loop through the collection of indexes.
For Each idxRep In tblRep.Indexes
' Ignore replication-related indexes:
' s_Generation, s_GUID
If InStr(1, idxRep.Name, "s_", vbTextCompare) = 0 Then
' Ignore indices set as part of Relation Objects
If Not idxRep.Foreign Then
' Create an index with the same name.
Set idxNew = tblNew.CreateIndex(idxRep.Name)
' Set properties.
idxNew.Clustered = idxRep.Clustered
idxNew.IgnoreNulls = idxRep.IgnoreNulls
idxNew.Primary = idxRep.Primary
idxNew.Required = idxRep.Required
idxNew.Unique = idxRep.Unique
' Loop through the collection of index fields.
For Each fldRep In idxRep.Fields
' Create an index field with the same name.
Set fldNew = idxNew.CreateField(fldRep.Name)
' Set properties.
fldNew.Attributes = fldRep.Attributes
' Append the index field.
idxNew.Fields.Append fldNew
Next fldRep
' Append the index to the table.
tblNew.Indexes.Append idxNew
End If
End If
Next idxRep
' Append the table.
dbNew.TableDefs.Append tblNew
End If
DoEvents
Next tblRep
'********************
Debug.Print "Copy Data"
'********************
' Loop through the list of table definitions.
For Each tblRep In dbRep.TableDefs
Set rec1 = dbRep.OpenRecordset("SELECT MSysObjects.Name FROM MsysObjects WHERE ([Name] = '" & tblRep.Name & "') AND ((MSysObjects.Type)=4 or (MSysObjects.Type)=6)")
If rec1.EOF Then
XF = 0
Else
XF = 1
End If
' Ignore system tables and CMDB tables.
If InStr(1, tblRep.Name, "MSys", vbTextCompare) = 0 And _
InStr(1, tblRep.Name, "CMDB", vbTextCompare) = 0 And _
XF = 0 Then
' Open a recordset for the new table.
Set rstNew = dbNew.OpenRecordset(tblRep.Name, dbOpenTable)
' Open a recordset for the old table.
Set rstRep = dbRep.OpenRecordset(tblRep.Name, dbOpenTable)
' Continue if there are records.
If Not rstRep.BOF Then
' Move to the first record.
rstRep.MoveFirst
' Loop through all the old table records.
Do Until rstRep.EOF
' Add a record to the new table.
rstNew.AddNew
' For each field in the new table, set the value
' to the value in the related field of the old table.
For intC = 0 To rstNew.Fields.count - 1
rstNew.Fields(intC).Value = _
rstRep.Fields(rstNew.Fields(intC).Name).Value
Next
' Update the new table.
rstNew.Update
' Move to the next old table record.
rstRep.MoveNext
Loop ' rstRep
End If
' Close the new recordset.
rstNew.Close
' Close the old recordset.
rstRep.Close
End If
DoEvents
Next tblRep
End If
I've searched far and wide and I can't quite find anything to fit my needs.
The situation:
I have two lists of data with the same type data in each column (10 columns but the last 2 are useless), but the lists are of varying length (currently 55k in one, 18k in the other). The longer list is going to be a running list of items with the most up to date data in each column for the unique ID # in column A. The other list is linked to a SharePoint list that I update a couple times each day.
The need:
I need the list that updates from SharePoint to be compared to the running list. If there are matching Unique ID #'s in the lists, then the running list needs to be updated to the pulled data. If the running list doesn't contain a Unique ID that is in the pulled list, the new line needs to be added to the running list (which will be sorted later).
I first tried doing this with cell references in two for loops and for only 10 rows this worked fine. When I tried running it for every line, I had problems. So I tried using arrays instead, but this is new territory for me. The code seems to be working, but it's taking a really long time to run (I've let it go for 10 minutes before force stopping). I've tried adding some efficiency increases like turning off screen updating and calculations, but they shouldn't have any effect since I'm using arrays and not actually updating the cells until the array comparison is finished. If arrays are more efficient, great, but I don't know how to combine the data from the pulled list's array to the running list's array.
Here is the code that I have so far:
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
Any direction would be much appreciated.
This ran in <1 sec for me, using 20k rows "data", ~3k rows "pull" (mix of updates and new).
EDIT: tidied up and added some comments...
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
You would be better off using MSAccess to do this. Link to both tables and then do an inner join on the id field or which ever field links the items in the two lists.