Batman,
Batman,
I have been off tinkering with the code you sent before this last. Yes, it was returning all the FirstMatch rows (or 9 rows with the our test file) (or 39 rows with my larger test file)
As you have already discovered, to return FirstMatch and duplicate rows then you must cycle every NDS file name for every REF file name(s).
The MyDemo() below was what I have come up with and was testing before your last post. The Sub YourLastModified() below is your last with a modification to either FirstMatch or Duplicate. Both return 9 rows with FirstMatch option on and 12 rows with FirstMatch option off.
You are light years ahead of me with using the Scripting.Dictionary (My hat is off to you). The time difference with our small sample test file is insignificant.
With the larger file 440,000 REF_SHEET rows. Your method is about 0.4 seconds faster. However either method is about 4 seconds faster than what I currently have coded in the userform.
The only advantage with Sub MyDemo() is that the arrangement of the REF/Control# in the Overlay match those in the REF. That can easily be fixed. So no, worries.
Now, there is much more “mud” in the mix, so my next step is to see if I can accommodate the other Dup row options (I think I can).
Another chap is off looking at using PowerQuery, to achieve the desired result. Will just have to wait as see what he comes up with.
In any case this has been a tremendous learning experience for me and I thank you very much for for your time and interest.
Code:
Option Explicit
Sub MyDemo()
Dim lastRow As Long, pos As Long, i As Long, j As Long, count As Long, curr_row As Long, filename As String, key, item, data(), find_data(), result(), dic As Object
Dim arrItems
Dim lngIndex As Long
Dim bMatchFirst As Boolean
Dim Start
Start = Timer
bMatchFirst = False
With Worksheets("OVERLAY")
'cleaning old results
lastRow = .Cells(Rows.count, "A").End(xlUp).Row
If lastRow > 1 Then .Range("A2").Resize(lastRow - 1, 9).ClearContents
End With
With Worksheets("NDS_SHEET")
lastRow = .Cells(Rows.count, "A").End(xlUp).Row
If lastRow = 4 Then Exit Sub ' there is no data in NDS_SHEET
data = .Range("A5").Resize(lastRow - 4, 8).value ' A:H to data
End With
With Worksheets("REF_SHEET")
lastRow = .Cells(Rows.count, "A").End(xlUp).Row
If lastRow = 1 Then Exit Sub ' there is no data in REF_SHEET
find_data = .Range("A2").Resize(lastRow - 1, 2).value
End With
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
For i = 1 To UBound(data, 1)
filename = data(i, 8) ' column 8 sheet NDS_SHEET
'we only take the first occurrence of a given filename
'If Not dic.Exists(filename) Then dic.Add filename, i
'No. We take "ALL" filesnames.
dic.Add i, filename
Next i
arrItems = dic.Items
ReDim result(1 To UBound(find_data, 1), 1 To 9)
For i = 1 To UBound(find_data, 1)
For lngIndex = 0 To UBound(arrItems)
'For Each key In dic.Keys
'pos = InStr(1, find_data(i, 2), key, vbTextCompare)
pos = InStr(1, find_data(i, 2), arrItems(lngIndex), vbTextCompare)
If pos Then
count = count + 1
result(count, 1) = find_data(i, 1)
'curr_row = dic.Keys(i).Value ' line number in data() with given filename
curr_row = lngIndex + 1 'dic.Items(lngIndex).Value
For j = 1 To 8
result(count, j + 1) = data(curr_row, j)
Next j
If bMatchFirst Then Exit For
End If
Next lngIndex
Next i
If count Then Worksheets("OVERLAY").Range("A2").Resize(count, 9).value = result
Set dic = Nothing
MsgBox Timer - Start
End Sub
Sub YourLastModified()
Dim Start
Start = Timer
Dim lastRow As Long, pos As Long, i As Long, j As Long, k As Long, count As Long, curr_row As Long, filename As String, key, item, data(), find_data(), result(), dic As Object
Dim bFirstMatch As Boolean
bFirstMatch = False
With Worksheets("OVERLAY")
' cleaning old results
lastRow = .Cells(Rows.count, "A").End(xlUp).Row
If lastRow > 1 Then .Range("A2").Resize(lastRow - 1, 9).ClearContents
End With
With Worksheets("NDS_SHEET")
lastRow = .Cells(Rows.count, "A").End(xlUp).Row
If lastRow = 4 Then Exit Sub ' there is no data in NDS_SHEET
data = .Range("A5").Resize(lastRow - 4, 8).value ' A:H to data
End With
With Worksheets("REF_SHEET")
lastRow = .Cells(Rows.count, "A").End(xlUp).Row
If lastRow = 1 Then Exit Sub ' there is no data in REF_SHEET
find_data = .Range("A2").Resize(lastRow - 1, 2).value
End With
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
For i = 1 To UBound(data, 1)
filename = data(i, 8) ' column 8 sheet NDS_SHEET
If Not dic.Exists(filename) Then
ReDim item(1 To 1)
' first duplicate row number
item(1) = i
dic.Add filename, item
Else
item = dic.item(filename)
ReDim Preserve item(1 To UBound(item) + 1)
' next duplicate row number
item(UBound(item)) = i
dic.item(filename) = item
End If
Next i
' in case of and duplicates in NDS_SHEET and duplicates in REF_SHEET the result array is the largest
ReDim result(1 To UBound(find_data, 1) * UBound(data, 1), 1 To 9)
For Each key In dic.Keys
item = dic.item(key) ' array of duplicate row numbers in column H sheet NDS_SHEET
For i = 1 To UBound(find_data, 1)
pos = InStr(1, find_data(i, 2), key, vbTextCompare)
If pos Then
For k = 1 To UBound(item)
'If k > 1 Then MsgBox item(k)
count = count + 1
result(count, 1) = find_data(i, 1)
curr_row = item(k) ' line number in data() with given filename
For j = 1 To 8
result(count, j + 1) = data(curr_row, j)
Next j
If bFirstMatch Then Exit For
Next k
End If
Next i
Next key
If count Then Worksheets("OVERLAY").Range("A2").Resize(count, 9).value = result
Set dic = Nothing
MsgBox Timer - Start
End Sub