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.
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.
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?
Any particular type of values? Any leading/trailing space on values ?
Hi guys, to both of you:Quote:
Originally Posted by Admin
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.
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.
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
Quote:
Originally Posted by Excel Fox
It's grinding it, I'll let you know as soon as it's finished.
Again I missed the last row part. In my test I hard coded last row as 100000. Give this a try.Quote:
Originally Posted by cyphrevil
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
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
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.
Quote:
Originally Posted by cyphrevil
it's giving me error number 14 'out of string' message.
Hi
Please DO NOT quote the entire post.
Try this one.
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 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