.Sort + RemoveDuplicates

Option Explicit
Option Compare Text

Sub CreateUniqDataFiles()
' ZVI:2017-11-28 http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&TID=98608
  
  Const IsLog As Boolean = True
  
  Dim a(), b(), v
  Dim FF As Integer
  Dim i As Long, j As Long
  Dim Rng As Range
  Dim s As String, f As String, p As String
  Dim t As Single, tt As Single
  
  Debug.Print "== Start " & Now
  tt = Timer
  p = ThisWorkbook.Path & "\OutFiles"
  Set Rng = ThisWorkbook.Sheets(1).UsedRange.Resize(, 2)
  With Rng
    ' Calc lengths
    t = Timer
    With .Columns(2)
      .Formula = "=LEN(A1)"
      .Value = .Value
      ReDim b(WorksheetFunction.Min(.Cells) To WorksheetFunction.Max(.Cells))
      .ClearContents
    End With
    If IsLog Then Debug.Print "Length", Round(Timer - t, 3), "Total = " & Round(Timer - tt, 3)
    ' Sort
    t = Timer
    Rng.Sort .Cells(2), xlAscending, .Cells(1), , xlAscending, Header:=xlNo
    If IsLog Then Debug.Print "Sort", Round(Timer - t, 3), "Total = " & Round(Timer - tt, 3)
  End With
    
  ' Put values into a()
  t = Timer
  a() = Rng.Columns(1).Value
  If IsLog Then Debug.Print "a()", Round(Timer - t, 3), "Total = " & Round(Timer - tt, 3)
    
  ' Main
  t = Timer
  For i = 1 To UBound(a)
    j = Len(a(i, 1))
    If j > 0 And a(i, 1) <> s Then
      s = a(i, 1)
      If Not IsObject(b(j)) Then Set b(j) = New Collection
      b(j).Add s
    End If
  Next
  If IsLog Then Debug.Print "Main", Round(Timer - t, 3), "Total = " & Round(Timer - tt, 3)
  
  ' Create/Append files
  t = Timer
  If Dir(p, vbDirectory) = "" Then MkDir p
  For i = LBound(b) To UBound(b)
    If IsObject(b(i)) Then
      ' Copy content of the Collection to the s
      j = 0
      ReDim a(1 To b(i).Count + 1)
      For Each v In b(i)
        j = j + 1
        a(j) = v
      Next
      Set b(i) = Nothing
      s = Join(a, vbCrLf)
      ' Append data to the end of file
      f = p & "\" & Format(i, "0000") & ".txt"
      FF = FreeFile
      Open f For Binary Access Write As FF
      Seek FF, LOF(FF) + 1
      Put FF, , s
      Close FF
    End If
  Next
  If IsLog Then Debug.Print "Files", Round(Timer - t, 3), "Total = " & Round(Timer - tt, 3)
  
End Sub

"text string"

Public Sub UniquesADO()
    Const conStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Files\DemoUnion\CSV\;" & _
    "Extended Properties='text;HDR=Yes;FMT=Delimited';"
    
    Dim sSQL As String, lSQL As String
    Dim vStart As Single
    Dim Base() As Variant
    Dim i As Long
    Dim pConn As New ADODB.Connection
    Dim Conn As New ADODB.Connection
    Dim mrs As New ADODB.Recordset
    
    vStart = Timer
    
    lSQL = "Select [fname] From [base1.csv] WHERE LEN(fname)>255"
    
    sSQL = "Insert Into [result.csv] ([fname])"
    sSQL = sSQL & " Select [fname] From ("
    sSQL = sSQL & " Select [fname] From [base1.csv] WHERE LEN(fname)<256 GROUP BY [fname]) timport"
    
    pConn.Open conStr
    pConn.Execute sSQL, 128
    pConn.Close
    
    Conn.Open conStr
    mrs.Open lSQL, Conn
    
    On Error Resume Next

    i = 0
    
    ReDim Base(0 To 0)
    
    Do While Not mrs.EOF
    If Base(i) = Empty Then
    Base(i) = mrs.Fields(0).Value
    
    Else
    
    If mrs.Fields(0).Value <> Base(i) Then
    i = i + 1
    ReDim Preserve Base(0 To i)
    Base(i) = mrs.Fields(0).Value
    End If
    End If
    
    mrs.MoveNext
    Loop
    
    mrs.Close
    Conn.Close
    
    CollectionUniq Base
    
    Filename = "C:\Files\DemoUnion\CSV\result.csv"
    
    Open Filename For Append As #1
    For i = 0 To UBound(Base)
    Write #1, Base(i)
    Next i
    
    Close #1
    
    Debug.Print Timer - vStart
    
    End Sub

Public Sub CollectionUniq(ByRef StringArray() As Variant)
  Dim x, y, Arr, i As Long, t As Single
  
  ReDim Arr(LBound(StringArray) To UBound(StringArray))
  Arr = StringArray
  If IsArray(Arr) Then
    ReDim y(0 To UBound(Arr))
    With New Collection
      On Error Resume Next
      For Each x In Arr
        If Len(x) > 0 Then
          Err.Clear
          .Add 0, CStr(x)
          If Err = 0 Then
            y(i) = x
            i = i + 1
          End If
        End If
      Next
    End With
  End If
  
  If y(i) = Empty Then
  ReDim Preserve y(0 To i - 1)
  End If
StringArray = y
End Sub