This post is in reply to the ‘duplicate values in VBA range‘ question on Microsoft Q&A forums.
Here’s a function that when called, will take your incoming data as an array, and compare it to another array. It also accepts a 0 to 1 percentage value for accuracy. E.g. 0.75 would enforce a 75% match requirement.
Function detect_duplicates(ByVal incomingData, dataToMatch, dataMatchRatio) 'Loop first through new data array For a = 1 To UBound(incomingData) 'Nested loop through comparison data array For b = a To UBound(dataToMatch) 'Compare values between arrays If incomingData(a) = dataToMatch(b) Then 'If values are the same then increase duplicateRatio duplicateRatio = duplicateRatio + 1 End If Next b Next a 'Case the actual percentage of similarity Select Case (duplicateRatio / UBound(dataToMatch)) 'If the percentage exceeds threshold value Case Is >= dataMatchRatio 'Prompt user to identify threshold and to alert that threshold is exceeded MsgBox "A " & (dataMatchRatio * 100) & "% match or over has been found! You may be duplicating data. Aborting..." 'Data set is a duplicate detect_duplicates = 1 Case Is < dataMatchRatio 'Data set is not a duplicate detect_duplicates = 0 End Select End Function
Now that you have the function to detect duplicates, here’s how to call it with sample data sets:
Sub Execute() 'Create arrays Dim incomingData(1 To 4) As Integer Dim dataToMatch(1 To 4) As Integer Dim duplicated 'CASE 1 'Data is not duplicate incomingData(1) = 1 incomingData(2) = 2 incomingData(3) = 3 incomingData(4) = 4 dataToMatch(1) = 5 dataToMatch(2) = 6 dataToMatch(3) = 7 dataToMatch(4) = 8 'CASE 2 'Data is duplicate ' incomingData(1) = 1 ' incomingData(2) = 2 ' incomingData(3) = 3 ' incomingData(4) = 4 ' dataToMatch(1) = 1 ' dataToMatch(2) = 2 ' dataToMatch(3) = 3 ' dataToMatch(4) = 4 'CASE 3 'Data may be duplicated but with values in different position ' incomingData(1) = 1 ' incomingData(2) = 2 ' incomingData(3) = 3 ' incomingData(4) = 4 ' dataToMatch(1) = 1 ' dataToMatch(2) = 2 ' dataToMatch(3) = 5 ' dataToMatch(4) = 3 'Call detect_duplicates function duplicated = detect_duplicates(incomingData, dataToMatch, 0.75) If duplicated = 1 Then 'If percentage of similarity is reached or exceeded then kill execution Exit Sub End If End Sub
Call the function prior to your main code block, assess the result and exit the sub to prevent duplicate data insertion. You can automatically compute the dataToMatch array using range to array conversions of arrays with or without similar lengths.