Prevent data duplication in Excel VBA

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.

0
VBA Choice MessageBox Rename-Computer.ps1

No Comments

No comments yet

Leave a Reply

Your email address will not be published. Required fields are marked *