tiredofit
Well-known Member
- Joined
- Apr 11, 2013
- Messages
- 1,926
- Office Version
- 365
- 2019
- Platform
- Windows
This code is taken from here:
It removes duplicates using the SQL command DISTINCT.
The problem is it works for a small column of data, say 10 values but for something like 300,000 values, it returns only a few thousand records, when the true value should be 150,000.
What is wrong?
Code:
https://www.ozgrid.com/forum/forum/tip-tricks-code-no-questions/advanced-excel-integration/7960-create-a-unique-list-with-ado-sql-from-closed-workbooks-xl
It removes duplicates using the SQL command DISTINCT.
The problem is it works for a small column of data, say 10 values but for something like 300,000 values, it returns only a few thousand records, when the true value should be 150,000.
What is wrong?
Code:
Option Explicit
Sub Create_Unique_List()
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stCon As String, stSQL As String
Dim i As Long, lnMode As Long
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
stCon = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & wbBook.FullName & ";" _
& "Extended Properties=""Excel 8.0;HDR=YES"";"
'The keyword DISTINCT generate a unique list in the SQL-statement."
'All the column in the worksheet Sheet1 have fieldnames in the first row
'which we all use here.
stSQL = "SELECT DISTINCT Data FROM [Sheet1$]"
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
cnt.Open stCon
rst.Open stSQL, cnt, adOpenStatic, adLockOptimistic
'A check to see that records actually exist.
If Not rst.EOF Then
With Application
.ScreenUpdating = False
'Collect the present calculation-mode.
lnMode = .Calculation
.Calculation = xlCalculationManual
'Add a new worksheet
Worksheets.Add Before:=wsSheet
'Copy the records to the added worksheet.
ActiveSheet.Cells(2, 1).CopyFromRecordset rst
'Reset the calculation-mode.
.Calculation = lnMode
.ScreenUpdating = True
End With
Else
MsgBox "No records could be find!", vbCritical
End If
'Cleaning up
If CBool(rst.State And adStateOpen) Then rst.Close
Set rst = Nothing
If CBool(cnt.State And adStateOpen) Then cnt.Close
Set cnt = Nothing
End Sub