Remove Duplicates From Across Multipe Columns In A Single WorkSheet

[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.

[Excel Fox]

I just noticed that my code isn't working when the length of text in any cell is greater than 255 characters. Does your data have any such values?

[Admin]

Any particular type of values? Any leading/trailing space on values ?

[cyphrevil]

Any particular type of values? Any leading/trailing space on values ?

Hi guys, to both of you:

The data are email addresses, this is an outcome of my routers logs. There should be nothing even remotely close to 255 characters length.
Thanks again.

[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.

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]

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.

Sub ExcelFox()
        
    Dim lng As Long
   ...

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

[Admin]

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.

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

[cyphrevil]

The previous one just ended with 'out of memory' message.

I'm going to reboot the machine and try the new code. Will update asap.

[cyphrevil]

The previous one just ended with 'out of memory' message.

I'm going to reboot the machine and try the new code. Will update asap.

it's giving me error number 14 'out of string' message.

[Admin]

Hi

Please DO NOT quote the entire post.

Try this one.

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
    Dim Flg     As Boolean
    
    Const Block = 65000
    
    fd = Environ("temp") & "\"
    fn = "Test.txt"
    
    Set objFS = CreateObject("scripting.filesystemobject")
    
    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
        If i Mod 3 = 0 Then
            If Flg Then
                Set objFile = objFS.opentextfile(fd & fn, 8)
            Else
                Set objFile = objFS.opentextfile(fd & fn, 2, 0)
                Flg = True
            End If
            objFile.write strAll
            objFile.Close
            strAll = vbNullString
        End If
    Next
    If LenB(strAll) Then
        Set objFile = objFS.opentextfile(fd & fn, IIf(Flg, 8, 2), IIf(Flg, 0, 1))
        objFile.write strAll
        objFile.Close
    End If
    
    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