Remove Duplicates From Across Multipe Columns In A Single WorkSheet

**cyphrevil** · 10-26-2013, 06:52 PM

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** · 10-26-2013, 07:13 PM

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

**cyphrevil** · 10-26-2013, 07:49 PM

Resulted with column A with 1mln rows and B with 143k rows. Ends with values starting with 'z' so seems to be working, yet I still can't find certain values from main table.

I'm sure you'll have some ideas.

Thank you.

**Excel Fox** · 10-26-2013, 09:36 PM

I modified the code slightly, but not too different. It's working on 500 rows and 17 columns. Can you try this.

And here's the code.

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 clngLastColumn As Long = 17
    Const clngSteps As Long = 100000
    
    Set objDic = CreateObject("Scripting.Dictionary")
    Set wks = Worksheets("NameOfSheetWithDuplicateValues")
    For lng = 1 To clngLastColumn
        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
            For lngRow = 1 To UBound(var)
                objDic.Item(var(lngRow, 1)) = 0
            Next lngRow
        End With
    Next lng
    Erase var
    var = objDic.keys
    var = Application.Transpose(Application.Transpose(var))
    Set objDic = Nothing
    If wks.Parent.FullName <> wks.Parent.Name Then
        wks.Parent.Save
    End If
    lng = 1
    For lngRow = 1 To UBound(var) + Abs(LBound(var) = 0) Step clngSteps
        varIndex = Application.Transpose(Evaluate(clngSteps * (lng - 1) & "+ ROW(1:" & Application.Min(UBound(var) + Abs(LBound(var) = 0), clngSteps) & ")"))
        Cells(1, clngLastColumn + lng).Resize(Application.Min(UBound(var) + Abs(LBound(var) = 0), clngSteps)).Value2 = Application.Transpose(Application.Index(var, varIndex))
        lng = lng + 1
    Next lngRow
    Erase varIndex
    
End Sub

**cyphrevil** · 10-26-2013, 10:42 PM

Originally Posted by Excel Fox

I modified the code slightly, but not too different. It's working on 500 rows and 17 columns. Can you try this.

And here's the code.

Code:

Sub ExcelFox()
        
    Dim lng As Long
   ...

It's grinding it, I'll let you know as soon as it's finished.

**Admin** · 10-26-2013, 11:18 PM

Originally Posted by cyphrevil

Resulted with column A with 1mln rows and B with 143k rows. Ends with values starting with 'z' so seems to be working, yet I still can't find certain values from main table.

I'm sure you'll have some ideas.

Thank you.

Again I missed the last row part. In my test I hard coded last row as 100000. Give this a try.

Code:

Option Explicit

Sub kTest()
    
    Dim strAll  As String
    Dim i       As Long
    Dim r       As Long
    Dim n       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 = 65000
    
    strAll = "Temp"
    
    For i = 1 To 17
        d = 0
        n = Cells(Rows.Count, i).End(3).Row
        If n = 1 Then n = Rows.Count
        For r = 1 To n Step Block
            strAll = strAll & vbCrLf & Join(Application.Transpose(Cells(r, i).Resize(Application.Min(Block, Abs(n - 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