1. I tested on Overlay Tool Sample Data BM Ver 1.1.xlsm (Not this file: Overlay Tool Fam Rel Sample Data BM.xlsm) - 11:19 02/02/2025
2. Test
- Firstly click the button to InitiateOverlay --> OVERLAY
- Make the following changes and try again click the button to InitiateOverlay --> OVELAY (1)
- test code
Code:
Sub test()
Dim arr_old(), arr_new(), i As Long, j As Long
arr_old = Worksheets("OVERLAY").Range("A2:L837").value
arr_new = Worksheets("OVERLAY(1)").Range("A2:L837").value
For i = 1 To 836
For j = 1 To 12
If arr_old(i, j) <> arr_new(i, j) Then
Debug.Print i, j
End If
Next j
Next i
MsgBox "he he he"
End Sub
both sheets are identical
-------------------------
All changes:
1. In "Sub BuildOverLay" add
Code:
Dim count As Long, i As Long, k As Long
2. Before this fragment
Code:
If Not oFrm.optCreateFam Then
If lngRecordIndex Then oOS.Range("A2").Resize(lngRecordIndex, lngCols + 1).value = varOverlay_Data
Else
If lngRecordIndex Then oOS.Range("A2").Resize(lngRecordIndex, lngCols + 4).value = varOverlay_Data
End If
Paste this fragment
Code:
If oFrm.optCreateFam Then
oBasicBar.StatusMessage = "Defining Family relationship ... Please Wait"
For i = 1 To UBound(varOverlay_Data, 1)
varOverlay_Data(i, lngOS_FamColNum) = min3(varOverlay_Data, lngOS_FamMatchColIndex, varOverlay_Data(i, lngOS_FamMatchColIndex), lngOS_NDSRIColNum)
If varOverlay_Data(i, lngOS_FamColNum) <> varOverlay_Data(i, 1) Then
' -----------------------
' instead of CountIfs - start
count = 0
For k = 1 To UBound(varOverlay_Data, 1)
If varOverlay_Data(k, lngOS_FamMatchColIndex) = varOverlay_Data(i, lngOS_FamMatchColIndex) Then
If varOverlay_Data(k, 1) = varOverlay_Data(i, lngOS_ParColNum) Then
count = count + 1
End If
End If
Next k
' instead of CountIfs - end
' ---------------------
If count = 0 Then
varOverlay_Data(i, lngOS_ParColNum) = varOverlay_Data(i, lngOS_FamColNum)
End If
End If
Next i
End If
3. New version of function min3
Code:
Private Function min3(varOverlay_Data, ByVal lngOS_FamMatchColIndex As Long, ByVal strFamily As String, ByVal lngOS_NDSRIColNum As Long) As String
Dim lngIndex As Integer, rM As Integer
Dim bFirstMatch As Boolean, count As Long, i As Long
bFirstMatch = True
rM = varOverlay_Data(1, lngOS_NDSRIColNum) ' 205
min3 = varOverlay_Data(1, 1) ' ''#2.1
For lngIndex = 1 To UBound(varOverlay_Data, 1)
If varOverlay_Data(lngIndex, lngOS_FamMatchColIndex) = strFamily Then ' 38
If bFirstMatch Then
rM = varOverlay_Data(lngIndex, lngOS_NDSRIColNum) ' 205
min3 = varOverlay_Data(lngIndex, 1) ' #2.1
bFirstMatch = False
Else
If rM > varOverlay_Data(lngIndex, lngOS_NDSRIColNum) Then
rM = varOverlay_Data(lngIndex, lngOS_NDSRIColNum) ' 204/203
min3 = varOverlay_Data(lngIndex, 1) ' #98.1/#665.1
End If
End If
End If
Next
' ------------------------
' instead of CountIfs - start
count = 0
For i = 1 To UBound(varOverlay_Data, 1)
If varOverlay_Data(i, lngOS_NDSRIColNum) = rM Then count = count + 1
Next i
' instead of CountIfs - end
' ------------------------
If count > 1 Then
min3 = varOverlay_Data(1, 1)
bFirstMatch = True
For lngIndex = 1 To UBound(varOverlay_Data, 1)
If varOverlay_Data(lngIndex, lngOS_NDSRIColNum) = rM Then
If bFirstMatch Then
min3 = varOverlay_Data(lngIndex, 1)
bFirstMatch = False
Else
If stripNonNums(min3) > stripNonNums(varOverlay_Data(lngIndex, 1)) Then
min3 = varOverlay_Data(lngIndex, 1)
End If
End If
End If
Next
End If
lbl_Exit:
Exit Function
End Function
4. Change to (I added Byval)
Code:
Private Function stripNonNums(ByVal strText As String)
Tomorrow I will write a version of CountIfs using Dictionary