Remove Duplicates From Across Multipe Columns In A Single WorkSheet

[snb]

assumptions:

- data in sheet1
- row 1 doesn't contain fieldnames
- no empty rows in the usedrange
- 17 columns that contain data

Sub M_snb()
  sn=sheet1.cells(1).currentregion.resize(,17)

  with createobject("scripting.dictionary")
     for j=1 to ubound(sn)
       .item(join(application.index(sn,j,0)))=application.index(sn,j,0)
     next
     sheet2.cells(1).resize(.count,17)=application.index(.items,0,0)
  end with
End Sub

or another method

Sub M_snb()
  sn=sheet1.cells(1).currentregion.resize(,17)
  c00=""

 for j=1 to ubound(sn)
    if instr(c00 & "|" ,"|" & application.index(sn,j,0) & "|") then 
     sn(j,1)=""
    else
     c00=c00 & "|" & application.index(sn,j,0)
    end if
  next

  sheet1.cells(1).currentregion.resize(,17)=sn
  sheet1.columns(1).specialcells(4).entirerow.delete
End Sub

[cyphrevil]

Hi, only got another chance to get on it.

Unfortunately, same run-time error 14, out of string space.

[cyphrevil]

Hi again,

In this case both methods ended up with error code 13, type mismatch.

[Admin]

Hi, only got another chance to get on it.

Unfortunately, same run-time error 14, out of string space.

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

[cyphrevil]

No matter what I do it keeps giving me 'file not found' error code 53.

[Admin]

Hi

Replace this line

Set objFile = objFS.opentextfile(fd & fn, 2, 0)

with

Set objFile = objFS.opentextfile(fd & fn, 2, 1)

[cyphrevil]

YES, IT WORKS!!

Runs for about 5 minutes and results with nearly 2.8mln unique cells. Had to run it few times to check if every result is identical.
There can be no empty cells in any of the columns though - I mean until last cell used in the column.

Thank you thank you thank you

[Admin]

You are welcome !