Remove Duplicates From Across Multipe Columns In A Single WorkSheet

[cyphrevil]

Hi all,

I am in need of help, that's the short story.

I have almost 9 million cells with values in them and they occupy 17 columns in total (one sheet). Some of them take almost 1.04 mln rows, some 70k.

All I have to do is to remove duplicate values. I've tried advanced copy/paste/only-unique-values feature on excel but even though I'm working on nice Dell i7 8gb ram etc., I have found excel crashed in the morning.

Any help including vba will be very appreciated.

Many thanks in advance
T.

[Excel Fox]

Do you want the duplicates in each column removed, or should the data in the entire sheet be unique? If it's for each column, try this

Sub ExcelFox()
        
    Dim lng As Long
    Dim wks As Worksheet
    
    Set wks = Worksheets("NameOfSheetWithDuplicateValues")
    For lng = 1 To 17
        With wks
            .Range(.Cells(1, lng), .Cells(.Rows.Count, lng).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
        End With
    Next lng
    
End Sub

Note that this will only work for Excel 2007 and above.

[cyphrevil]

They are already unique in each column, need to remove duplicates between columns now..

Thanks anyway.

[Excel Fox]

Try this

Sub ExcelFox()
        
    Dim lng As Long
    Dim wks As Worksheet
    Dim objDic As Object
    Dim var As Variant
    Dim varIndex As Variant
    Dim lngRow As Long
    Const clngSteps As Long = 100000
    
    Set objDic = CreateObject("Scripting.Dictionary")
    Set wks = Worksheets("NameOfSheetWithDuplicateValues")
    For lng = 1 To 17
        With wks
            .Range(.Cells(1, lng), .Cells(.Rows.Count, lng).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
            var = .Range(.Cells(1, lng), .Cells(.Rows.Count, lng).End(xlUp)).Value2
            .Range(.Cells(1, lng), .Cells(.Rows.Count, lng).End(xlUp)).Clear
            For lngRow = 1 To UBound(var)
                objDic.Item(var(lngRow, 1)) = 0
            Next lngRow
        End With
    Next lng
    Erase var
    var = objDic.keys
    Set objDic = Nothing
    If wks.Parent.FullName <> wks.Parent.Name Then
        wks.Parent.Save
    End If
    lng = 1
    For lngRow = 1 To UBound(var) + 1 Step clngSteps
        varIndex = Evaluate(clngSteps * (lng - 1) & "+ ROW(1:" & Application.Min(UBound(var) + 1, clngSteps) & ")")
        Cells(1, lng).Resize(Application.Min(UBound(var) + 1, clngSteps)).Value = Application.Index(var, varIndex)
        lng = lng + 1
    Next lngRow
    Erase varIndex
    
End Sub

[cyphrevil]

Thank you so much for your effort. The script ran for 2 hours then crashed at below line:

Cells(1, lng).Resize(Application.Min(UBound(var) + 1, clngSteps)).Value = Application.Index(var, varIndex)

Error message said 'mismatch error'

also, the sheet has been cleared of all data - if it's of any help to you.

Kind Regards

[Excel Fox]

What's your formula separator? Is it : or something else?

Also, can you test this on a much smaller sample.. maybe 10000 rows and 17 columns.... If it works, then I'll come up with something else. If it doesn't work, then something's wrong with the data.

[Admin]

Hi

Here is a different method.

Option Explicit

Sub kTest()
    
    Dim strAll  As String
    Dim i       As Long
    Dim r       As Long
    Dim d       As Long
    Dim fd      As String
    Dim fn      As String
    Dim objFS   As Object
    Dim objFile As Object
    Dim adoConn As Object
    Dim adoRset As Object
    
    Const Block = 32000
    
    strAll = "Temp"
    
    For i = 1 To 5
        d = 0
        For r = 1 To 100000 Step Block
            strAll = strAll & vbCrLf & Join(Application.Transpose(Cells(r, i).Resize(Application.Min(Block, Abs(100000 - d))).Value2), vbCrLf)
            d = d + Block
        Next
    Next
    
    fd = Environ("temp") & "\"
    fn = "Test.txt"
    
    Set objFS = CreateObject("scripting.filesystemobject")
    Set objFile = objFS.opentextfile(fd & fn, 2, 1)
    
    objFile.write strAll
    objFile.Close
    
    Set adoConn = CreateObject("ADODB.Connection")
    
    adoConn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
                "Dbq=" & fd & ";Extensions=txt;"
        
    Set adoRset = CreateObject("ADODB.Recordset")
        adoRset.Open "SELECT [Temp] FROM [" & fn & "] GROUP BY [Temp]", adoConn, 3, 1, 1
            
    d = adoRset.RecordCount
    
    ActiveSheet.UsedRange.ClearContents
    
    If d > Rows.Count Then
        i = 1
        While Not adoRset.EOF
            Cells(1, i).CopyFromRecordset adoRset, 1000000
            i = i + 1
        Wend
    Else
        Range("a1").CopyFromRecordset adoRset
    End If
    
    adoRset.Close
    adoConn.Close
    
    Kill fd & fn
    
End Sub

[cyphrevil]

What's your formula separator? Is it : or something else?

Also, can you test this on a much smaller sample.. maybe 10000 rows and 17 columns.... If it works, then I'll come up with something else. If it doesn't work, then something's wrong with the data.

On 10000 rows it removed all the content and then displayed the same error in the same line.

My formula separator seems to be , and not :

[cyphrevil]

Hi,

This is regarding 'different method':

Tried the code, worked for about 20-30 seconds and left me with only column A populated to around 440k rows. Not just unique values cause I can't find some entries from the full 17 columns table.

Thank you for all your help as I still can't figure this out on my own

[Admin]

Hi,

This is regarding 'different method':

Tried the code, worked for about 20-30 seconds and left me with only column A populated to around 440k rows. Not just unique values cause I can't find some entries from the full 17 columns table.

Thank you for all your help as I still can't figure this out on my own

My bad

I tested this code with 5 columns of data.

replace

For i = 1 To 5

with

For i = 1 To 17