I need to find the earliest & latest dates for certain table entries.
A link to a diagram of the table.
The premise is that every time an entry has a desired pairing of "Name" and "Desc" I want to grab the date, and then find the earliest & latest dates associated with that pairing.
My solution was to create an Array variable, save all the dates in integer form (Long) and then print the Min and Max functions of that Array.
The first date the loop encounters isn't saving to the array, so the first element is always "0" and there's always a date missing.
Sub Test2()
'Search a table for specied subject / entry description, to find the earliest & latest corresponding dates
'Empty array variable for later use
Dim TheDates() As Long
Dim Xds As String
Dim Xnm As String
Dim NameR As Range
Dim Counter As Integer
Dim Dum As Integer
'Placeholder values assigned to Xds and Xnm for testing
Xds = "Charlie # £8.50"
Xnm = "Beatriz"
'Counter set to 0
Counter = 0
ReDim TheDates(Counter)
'Run through each entry in the table
For Each NameR In Range("Draft[Name]")
'Check if an entry contains the desired pairing of Name & Desc ( Xnm & Xds )
If NameR.Value = Xnm And NameR.Offset(0, 8).Value = Xds Then
'In cases they match follow the below procedure
'Set the array size of 'TheDates' to current counter value
'Set the 'counter'th element in the array to the entry's date
'Increment the Counter ready for the next case
ReDim TheDates(Counter)
TheDates(Counter) = CDbl(NameR.Offset(0, 3))
Counter = Counter + 1
'When an entry does not match the desired pairing it is ignored
Else
End If
Next
'For testing purpose I am printing the end results to the page
Range("N13") = WorksheetFunction.Min(TheDates)
Range("N14") = WorksheetFunction.Max(TheDates)
'I am also printing the array in its entirey to analyse
For Dum = 0 To Counter - 1
Range("Q13").Offset(Dum, 0) = TheDates(Dum)
Next
End Sub
Related
Suppose I have the following table with three columns. I want to search for an exact match or next previous date from Column3, conditional to Column1 being a given value.
This can be easily done with XLOOKUP. However, I need to do so in VBA because I'll show the date found in a userform Textbox to the user. From what I have searched so far, Application.Worksheetfunction.Xlookup won't work with an & for multiple criteria, so the solution for this would involve manipulating arrays.
I created a variant from that table by writing:
Dim TBL As ListObject
Set TBL = Sheets("sheet1").ListObjects("Table1")
Dim DirArray As Variant
DirArray = TBL.DataBodyRange
Any advice on how to get that approximate match using arrays?
Using an array of values will be faster than referencing a cell for each check - esp. if your table is much larger.
You can use this function - it will return 0 in case no valid date is found.
As I am using sortBy you will need Excel 365 for this to work.
By using SortBy it is safe to exit the for-loop in case we have found a matching date.
Public Function nearestDate(lo As ListObject, valueColumn1 As String, valueColumn3 As Date) As Date
Dim arrValues As Variant
arrValues = Application.WorksheetFunction.SortBy(lo.DataBodyRange, lo.ListColumns(1).DataBodyRange, 1, lo.ListColumns(3).DataBodyRange, 1)
Dim i As Long
For i = 1 To UBound(arrValues, 1)
If arrValues(i, 1) = valueColumn1 Then
If arrValues(i, 3) = valueColumn3 Then
'we found what we are looking for
nearestDate = arrValues(i, 3)
ElseIf arrValues(i, 3) < valueColumn3 Then
'we have to check next row - if there is one
If i < UBound(arrValues, 1) Then
If arrValues(i + 1, 1) = valueColumn1 And arrValues(i + 1, 3) > valueColumn3 Then
'same column1 but column3 greater than valueColumn3
nearestDate = arrValues(i, 3)
ElseIf arrValues(i + 1, 1) <> valueColumn1 Then
'new column1 value --> therefore we take current date
nearestDate = arrValues(i, 3)
End If
Else
'last value --> ok
nearestDate = arrValues(i, 3)
End If
End If
End If
If nearestDate > 0 Then Exit For
Next
End Function
You can call this function like this:
Public Sub test()
Dim ws As Worksheet: Set ws = Thisworkbook.Worksheets("sheet1")
Dim lo As ListObject: Set lo = ws.ListObjects("Table1")
Dim valueColumn1 As String: valueColumn1 = ws.Range("F1")
Dim valueColumn3 As Date: valueColumn3 = ws.Range("F2")
Debug.Print nearestDate(lo, valueColumn1, valueColumn3)
End Sub
There may well be a neater answer, but here is a simple brute-force function that just scans down every row in the given data looking for the closest match to the given criteria. The function returns the date of the closest match, but maybe it would be more useful to you if it returned, say, the row number of the row that is the closest match. Put this function in a new code module so that it can be called as a function from a cell, for example =findEntryByCol1andCol3(Table1,F1,F2)
Option Explicit
Public Function findEntryByCol1andCol3(dataToSearch As Range, findCol1, findCol3) As Variant
'// variable to hold the row with the closest match to criteria
Dim matchRow As Range
Set matchRow = Nothing
'// variable to hold the row being checked
Dim checkRow As Range
Dim ix As Long
For ix = 1 To dataToSearch.Rows.Count
'// get the next row to be checked
Set checkRow = dataToSearch.Rows(ix)
'// does column 1 in this row match the search criterion for column 1?
If checkRow.Cells(1, 1).Value = findCol1 Then
'// now see if the date in the row is less than the search date
If findCol3 >= checkRow.Cells(1, 3).Value Then
'// If there has been no match then use this checked row as the first found match
If matchRow Is Nothing Then
Set matchRow = checkRow
'// If there has been a previous match check
'// if the new date is later that the previously found date
ElseIf matchRow.Cells(1, 3).Value < checkRow.Cells(1, 3).Value Then
Set matchRow = checkRow
End If
End If
Else
End If
Next ix
'// Now return the result of the search
If matchRow Is Nothing Then
findEntryByCol1andCol3 = "Not found"
Else
findEntryByCol1andCol3 = matchRow.Cells(1, 3)
End If
End Function
I am trying to write a process that compares strings and deletes the duplicate string within a given column using a selection as the top and bottom constraints.
Most of the process of checking and deleting works however I am having trouble with moving the cell contents up a cell after the duplicate string was deleted.
Image showing how the script should work
Red outline is the loop that selects the String to compare against.
Green outline is the loop that finds, deletes and moves the cells up one.
Blue outline is the Selection.
Stage 1 is to find and compare two strings that are the same.
Stage 2 is to delete the string that is the same as the first string.
Stage 3 is to move everything under the deleted cell with the deleted string up one row so that there is no empty cell.
I'm having problems with stage 3. I don't know how to move all data in those cells up one row without using a loop and I can't use the selection.
Here is the code so far:
Private Sub Tabeller()
Dim vRngMv As Variant
Dim iRowChsr1, iRowChsr2, iRowTtl, iI As Integer
Dim vRowIn, vRowComp As String
Dim oRngSlct, oRngMv As Range: Dim ws As Worksheet: Dim oBS As Object
'Newer Version will get rid of Selection as range determination
'Why does oRngSlct become a Variant/Object/Range here and oRngMv stays a Range object?
'I dont use it, kept it in to ask the question.
Set oRngMv = Selection: Set oRngSlct = Selection
iRowTtl = oRngSlct.Rows.Count
'First Loop For holding target cell data for comparison
For iRowChsr1 = 1 To iRowTtl
'Chooses target cell and string
vRowIn = oRngSlct(iRowChsr1, 1)
'Second loop for Seeking a matching String
For iRowChsr2 = 1 To iRowTtl
'Check to not pick itself
If iRowChsr1 = iRowChsr2 Then
'Offsets Counter by 1 if it enocunters itself
iRowChsr2 = iRowChsr2 + 1
Else
'Sets comparison string
vRowComp = oRngSlct(iRowChsr2, 1)
'String comparison
iI = StrComp(vRowIn, vRowComp, 1)
'If strings are equal
If iI = 0 Then
'Deletes; I know this is redundant but its here for clarity
oRngSlct(iRowChsr2, 1) = ""
'Offsets by iRowChsr by 1
iRowChsr2 = iRowChsr2 + 1
'Create Variant with proper range, it just has to be translated into something that excel can move.
vRngMv = Range((oRngSlct(iRowChsr2, 1)), (oRngSlct(iRowTtl, 1)))
Set oRngMv = Range 'I know this doesnt work
'Offsets back to original Position of Deleted cell
iRowChsr2 = iRowChsr2 - 1
'*******************************
'*Cuts and pastes or moves here*
'*******************************
End If
End If
'Next Comparison String
Next iRowChsr2
'Next target String
Next iRowChsr1
End Sub
Unique (Remove Duplicates)
You could rather use one of the following.
The first solution will leave error values and blanks as part of the resulting data, while the second one will remove them.
The Code
Option Explicit
Sub removeDupesColumnSelection()
' Validate Selection.
If TypeName(Selection) <> "Range" Then Exit Sub
' Remove duplicates.
Selection.Columns(1).RemoveDuplicates Array(1), xlNo
End Sub
Sub uniquifyColumnSelection()
' Validate Selection.
If TypeName(Selection) <> "Range" Then Exit Sub
' Write values from first column of Selection to Data Array.
Dim rg As Range: Set rg = Selection.Columns(1)
Dim rCount As Long: rCount = rg.Rows.Count
Dim Data As Variant
If rCount > 1 Then
Data = rg.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
End If
' In Unique Dictionary...
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
' Write unique values from Data Array to Unique Dictionary.
Dim Key As Variant
Dim i As Long
For i = 1 To rCount
Key = Data(i, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = Empty
End If
End If
Next i
ReDim Data(1 To rCount, 1 To 1)
If .Count > 1 Then
' Write values from Unique Dictionary to Data Array.
i = 0
For Each Key In .Keys
i = i + 1
Data(i, 1) = Key
Next Key
End If
End With
' Write values from Data Array to Destination Range.
rg.Value = Data
End Sub
I am trying to put in place a macro that allows me to match identical entry from one table to another. The tricky part is that if a match is found, it cannot be repeated. The way I theorized it is kind of elementary, however it is the only way I can think of it given my still limited knowledge in VBA.
The structure
Both tables need to be first filtered in order to allow the non-repetition condition.
Store the searching values as arrays in order to speed up the process of the macro
Match the entries to search with the ones from the targeted table in order to find matches. This is done with the in-application function MATCH. The MATCH function returns the cell where the match is situated, this is useful as it constantly shift the range in order to not repeate the same value all the time.
After calculating the shifting range, I use a VLookup function in order to return the second entry.
Unfortunately, the macro is incomplete. I cannot find a way to constantly shift the range without compromising the mechanism. The problem resides in the shifting range that is not created correctly to shift after each match.
Desired result
In the below image the desired result would be to check if all items in the left table are in the right table. Take item A, I need to find two item As. I have in the right column a first item A with value 17 and a second item A with value 81. If I do not find any value I have nothing, as it is the case of Ds and E. If instead I have less entries in the left table (as it is for the case of entry L) then I need to return all values of Entry L: 96; 77; 40.
Sub Matching11()
ThisWorkbook.Activate
Worksheets.add
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
Dim Search_Array As Variant
Search_Array = Range("C2", Range("C1").End(xlDown)) 'use this array to loop through the value to search for
Dim Target_MatchValue As Integer
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
counter = 0
n = 0
Target_MatchValue = 0
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range("H2:H200"), 0) - 1 'change C column with the range where you will have the tyres you need search for
Set Target_Range = .Range(.Cells(2 + n, 8), .Cells(1000, 9)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'If arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) Is Nothing Then GoTo NextCounter 'I used Vlookup in order to return the value set in the second column of the targetted table. As alternative, I think I could just use offset since I previously used MQTCH
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False)
If IsError(arr) Then
GoTo NextCounter
Else
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = arr 'Return the value of the array in this cell
End If
Target_Range.Select
If Target_MatchValue = 0 Then
n = n + 1
ElseIf Target_MatchValue > 0 Then
n = n + Target_MatchValue
End If
.Range(Cells(1 + counter, 5), Cells(1 + counter, 5)).value = Search_Array(counter, 1) 'Return the value of the array in this cell
Next counter
NextCounter:
Next counter
End With
End Sub
Well, Let's see if this helps you out and probably you can adapt it to your needs.
I replied your data like this:
The macro will create a list in columns H:I like the right table of your image. The macro will always delete any previous result. My macro works on standard ranges, is not designed to work on tables (ListObjects in VBA), but you can easily adapt it to your needs.
Sub CREATE_LIST()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim MyRange As Range
Dim rng As Range
Dim i As Long
'we clear previous list
Columns("H:I").Delete
'we add data
Range("H1").Value = "Target"
Range("I1").Value = "Return"
LastRow = Range("C" & Rows.Count).End(xlUp).Row 'Last row of column C, where data is.
Set MyRange = Range("D2:D" & LastRow).SpecialCells(xlCellTypeConstants, 23) 'we select only NON BLANK cells
i = 2 'initial row
For Each rng In MyRange
Range("H" & i).Value = rng.Offset(0, -1).Value 'value of adjacent cell (Column C)
Range("I" & i).Value = rng.Value 'value of cell in column D
i = i + 1
Next rng
Application.ScreenUpdating = True
End Sub
After executing code I get:
And trying different data works too:
Hope you can adapt this to your needs.
Apologies for the unclear explanation of the problem. I have provided here below a solution I have sorted out. I was looking for a code that could execute vlookup without returning the same values. Below is the solution. I am aware that the code might not be the cleanest and most elegant one but it is effective and run fast enough for large data sample.
Sub Matching()
Dim Search_Array As Variant
Dim Target_MatchValue As Variant
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
'data must be ordered in order to apply the non-repetitive condition
Search_Array = Sheet1.Range("A2", Sheet1.Range("A1").End(xlDown)) 'use this array to loop through the value to search for
n = 0
Sheet1.Activate
With ActiveSheet
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range(Cells(2 + n, 4), Cells(1000, 4)), 0) 'This code will return the value used for the shifting range
Set Target_Range = .Range(Cells(2 + n, 4), Cells(1000, 5)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'target_range.select Activate this code in order to see the macro in action
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) 'store the vlookup value in an array in order to increase the efficiency the code and to speed up the whole proces
If IsError(arr) Then
.Cells(2 + n, 2).value = "" 'if the macro does not find anything, no value will be recorded anywhere
Else
.Cells(1 + n + Target_MatchValue, 2).value = Search_Array(counter, 2) 'Return the value of the search_array in this cell so to match column A values with column D values if they are found
End If
If IsError(arr) Then
n = n
ElseIf Target_MatchValue = 0 Then 'if the macro does not find anything, the shifting range does not shift so that subsequent values can be searched in the same range without missing precious matches
n = n + 1
ElseIf Target_MatchValue > 0 Then 'if there is a matching value between Column A and Column B, the shifting range shifts by the n + the distance between the the current vlookupvalue and the found value. Note that Data must be stored in a filtered order otherwise vlookup will not work correctly
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
By exchanging ideas with some friends, I was told to think about a potential helper column that would be used to store incremental numbers. This helper column would store incremental numbers that would help to meet the non-repetition condition. Please see the below example.
The idea here is that if a value is found in column E, I store n being equal to the value found in the helper column. Then the code needs to verify if the future values' n are bigger than previous n. If this condition is met, then the one-repetition condition is fulfilled. n changes value to the next bigger value.
For example, if I find L in the right table, I report 96 as value and store N being equal to 11. When I search for the next value of L, the new n must be bigger than the current n otherwise I will not store the new found value. The value 77 found has indeed a bigger n than the previous value as 12 is bigger than 11. I hope this helps.
I need to generate an array for a 'write line' custom function. This function writes a single row of cells (the array) to a text file during a loop.
This array is static in size.
The row to be written to the text file is 'detected' by the Rng variable below:
Set Rng = Worksheets("Sheet1").Columns(5).Find(userform1.ComboBox1.Value)
i.e. the Rng variable only indexes a single cell in column 5 - as matched by the value in ComboBox1. The array to be written by writeLine will be column 6:49 of the row matched by Rng.
The arguments for the 'write line' function are
the value of the combobox i.e. userform1.combobox1.value, and
the array to be written in the 'write line' function
So far, I have this:
Private Sub CommandButton18_Click()
Dim Range As Range
Dim Array As Range
Set Range = Worksheets("Sheet1").Columns(5).Find(userform1.ComboBox1.Value) ''anticipated to set the row index of the array???
Array = ????
Function.writeLine(userform1.ComboBox1.Value,????)
End Sub
The trouble I am having is to create an array that incorporates the changing row whilst having the number of columns fixed?
Here is part of the writeLine function:
Do Until objTF.AtEndOfStream
readString = objTF.readline
data = Split(readString, vbTab)
foundID = data(0)
If StrComp(**foundID, ID**, 1) <> 0 Then
objTF2.writeLine (readString)
ElseIf StrComp(**foundID, ID**, 1) = 0 Then
'write initial value outside the loop
strTmp = Split(readString, strDelim)
'Modify the data array to include the data provided by writeArray
For argPos = 5 To UBound(data)
'check for index out of bounds, stop writing if it is!
If (argPos - 5) > UBound(writeArray) Then Exit For 'need to check this will exit if the value is index out of bounds.
data(argPos) = writeArray(dataPos)
dataPos = dataPos + 1
Next argPos
'Take each entry from data and build a string delimited by strDelim
Do Until counter > UBound(data)
resultStr = IIf(counter <= UBound(data), resultStr & data(counter) & strDelim, resultStr & data(counter))
counter = counter + 1
Loop
'output to temp file
objTF2.writeLine (resultStr)...
Basically, the "foundID" and "ID" are the variables to be matched in order to write the array to the text file. The "ID" is the ComboBox1.value. "foundID" is the value in column 5 of the spreadsheet. Column 6:49 (the array) are to be written to the text file.
Use Ubound to get the range as array.
Private Sub CommandButton18_Click()
Dim rRange As Range
Dim colno As Long
Dim rownumber As Long
Dim sString As String
lastrow = 10
For colno = 6 To 43
For rownumber = 1 To lastrow
sString = Worksheets("sheet1").Cells(rownumber, colno)
Next rownumber
Next
End Sub
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.