Remove Duplicates From Across Multipe Columns In A Single WorkSheet

assumptions:

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

Code:

---

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

Code:

---

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

---

Hi, only got another chance to get on it.

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

Hi again,

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

Quote:

---

Originally Posted by cyphrevil

Hi, only got another chance to get on it.

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

---

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

---

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

Hi

Replace this line

Code:

---

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

---

with

Code:

---

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

---

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

You are welcome ! :cheers: