Remove Duplicates From Across Multipe Columns In A Single WorkSheet

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.

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

Code:

---

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.

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

Thanks anyway.

Try this

Code:

---

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

---

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

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.

Hi

Here is a different method.

Code:

---

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

---

Quote:

---

Originally Posted by 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.

---

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 :

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 :(

Quote:

---

Originally Posted by 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 :(

---

My bad :(

I tested this code with 5 columns of data.

replace

Code:

---

For i = 1 To 5

---

with

Code:

---

For i = 1 To 17

---