There are several ways to do that without a sort in a sheet.
This is one of them, using SQL via ADO on a text file:
Option Explicit
Private oADOTextConn As Object
Private Const TempTablesFolder As String = "C:\"
Private Const strTextConn = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\;" & _
"Extended Properties=Text;"
Sub test()
Dim arr
arr = Range(Cells(1), Cells(3, 2))
SQLArraySort arr, 1, "A", False, True, True, 2, , , 2, "D"
Range(Cells(4), Cells(3, 5)) = arr
End Sub
Sub SQLArraySort(arrData As Variant, _
lSortField1 As Long, _
strSortType1 As String, _
bHasFields As Boolean, _
bArrayInput As Boolean, _
bArrayOutput As Boolean, _
Optional lCols As Long, _
Optional strInputFile As String, _
Optional strOutputFile As String, _
Optional lSortField2 As Long, _
Optional strSortType2 As String)
Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
Dim c As Long
Dim strFields As String
Dim arrFields
Dim strQuery As String
Dim strOrderString As String
Dim strTempFile As String
Dim strSortedFile As String
Dim strSchemaFile As String
On Error GoTo ERROROUT
If Len(strInputFile) = 0 Then
strTempFile = TempTablesFolder & "tmpFile.txt"
strInputFile = "tmpFile.txt"
Else
strTempFile = TempTablesFolder & strInputFile
End If
If Len(strOutputFile) = 0 Then
strSortedFile = TempTablesFolder & "SortedFile.txt"
strOutputFile = "SortedFile.txt"
Else
strSortedFile = TempTablesFolder & strOutputFile
End If
strSchemaFile = TempTablesFolder & "Schema.ini"
If bArrayInput Then
KillFile strTempFile
End If
KillFile strSortedFile
KillFile strSchemaFile
If bArrayInput = False Then
If bHasFields = False Then
'working directly with a text file that has no fields yet
'--------------------------------------------------------
strFields = "Field" & c
If lCols > 1 Then
For c = 2 To lCols
strFields = strFields & ", Field" & c
Next c
End If
InsertLineAtBeginningTextFile strTempFile, strFields
Else
'working directly with a text file that has fields already
'---------------------------------------------------------
strFields = GetFieldsFromText(strTempFile, lCols)
End If
End If 'If bArrayInput = False
If bArrayInput Then
LB1 = LBound(arrData)
UB1 = UBound(arrData)
LB2 = LBound(arrData, 2)
UB2 = UBound(arrData, 2)
ReDim arrFields(LB2 To UB2) As String
'make the fields string and fields array
'---------------------------------------
If bHasFields = False Then
strFields = "Field" & 1 - LB2
arrFields(LB2) = "Field" & 1 - LB2
If UB1 > LB1 Then
For c = LB2 + 1 To UB2
strFields = strFields & ", " & "Field" & c + (1 - LB2)
arrFields(c) = "Field" & c + (1 - LB2)
Next c
End If
Else
strFields = arrData(LB1, LB2)
arrFields(LB2) = arrData(LB1, LB2)
If UB1 > LB1 Then
For c = LB2 + 1 To UB2
strFields = strFields & ", " & arrData(LB1, LB2 + c)
arrFields(c) = arrData(LB1, LB2 + c)
Next c
End If
End If 'If bHasFields = False
'write the array to text
'-----------------------
If bHasFields = False Then
SaveArrayToText strTempFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2, _
arrFields
Else
SaveArrayToText strTempFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2
End If
End If 'If bArrayInput = True
'make the SQL ORDER clause
'-------------------------
If lSortField2 = 0 Then
If strSortType1 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " DESC"
End If
Else
If strSortType1 = "A" Then
If strSortType2 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " ASC, " & _
lSortField2 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " ASC, " & _
lSortField2 & " DESC"
End If
Else
If strSortType2 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " DESC, " & _
lSortField2 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " DESC, " & _
lSortField2 & " DESC"
End If
End If
End If 'If lSortField2 = 0
'run the SQL to sort the text file
'---------------------------------
strQuery = "SELECT " & _
strFields & _
" INTO " & strOutputFile & _
" IN '" & TempTablesFolder & "' " & _
"'Text;FMT=Delimited' " & _
"FROM " & _
strInputFile & " " & _
strOrderString
OpenConnection strTextConn
ExecuteAction strQuery
If bArrayOutput Then
'write the textfile back to the array
'------------------------------------
If bHasFields Then
OpenTextFileToArray strSortedFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2
Else
OpenTextFileToArray strSortedFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2, _
True
End If
End If 'If bArrayOutput = Tru
Exit Sub
ERROROUT:
MsgBox "The sub SQLArraySort couldn't complete" & _
vbCrLf & _
"due to an error" & _
vbCrLf & vbCrLf & _
"Error number: " & Err.Number & _
vbCrLf & vbCrLf & _
Err.Description, , "SQLArraySort"
End Sub
Sub SaveArrayToText(ByVal strFile As String, _
ByRef arr As Variant, _
Optional ByVal LB As Long = -1, _
Optional ByVal UB As Long = -1, _
Optional ByVal LB2 As Long = -1, _
Optional ByVal UB2 As Long = -1, _
Optional ByRef fieldArr As Variant, _
Optional bTranspose As Boolean)
Dim r As Long
Dim c As Long
Dim hFile As Long
Dim str As String
If LB = -1 Then
LB = LBound(arr, 1)
End If
If UB = -1 Or UB > UBound(arr) Then
UB = UBound(arr, 1)
End If
If LB2 = -1 Then
LB2 = LBound(arr, 2)
End If
If UB2 = -1 Or UB2 > UBound(arr, 2) Then
UB2 = UBound(arr, 2)
End If
hFile = FreeFile
Open strFile For Output As hFile
If bTranspose Then
If IsMissing(fieldArr) Then
For r = LB2 To UB2
For c = LB To UB
If c = UB Then
Write #hFile, arr(c, r)
Else
Write #hFile, arr(c, r);
End If
Next
Next
Else
For c = LB To UB
If c = UB Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next
For r = LB2 To UB2
For c = LB To UB
If c = UB Then
Write #hFile, arr(c, r)
Else
Write #hFile, arr(c, r);
End If
Next
Next
End If
Else
If IsMissing(fieldArr) Then
For r = LB To UB
For c = LB2 To UB2
If c = UB2 Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
Else
For c = LB2 To UB2
If c = UB2 Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next
For r = LB To UB
For c = LB2 To UB2
If c = UB2 Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
End If
End If
Close #hFile
End Sub
Function KillFile(strFile As String) As Boolean
On Error GoTo ERROROUT
If bFileExists(strFile) Then
Kill strFile
KillFile = True
End If
ERROROUT:
End Function
Function bFileExists(ByVal sFile As String) As Boolean
Dim lAttr As Long
On Error Resume Next
lAttr = GetAttr(sFile)
bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0)
On Error GoTo 0
End Function
Sub InsertLineAtBeginningTextFile(strFile As String, strLine As String)
Dim strBuffer As String
strBuffer = OpenTextFileToString3(strFile)
If Right$(strLine, 2) = vbCrLf Then
strBuffer = strLine & strBuffer
Else
strBuffer = strLine & vbCrLf & strBuffer
End If
StringToTextFile strFile, strBuffer
End Sub
Sub StringToTextFile(strFile As String, strText As String)
Dim hFile As Long
On Error GoTo ERROROUT
hFile = FreeFile
Open strFile For Binary As #hFile
Put #hFile, , strText
Close #hFile
Exit Sub
ERROROUT:
If hFile > 0 Then
Close #hFile
End If
End Sub
Function GetFieldsFromText(ByVal strFile As String, ByVal lCols As Long) As
String
Dim hFile As Long
Dim strTemp As String
Dim strResult As String
Dim c As Long
hFile = FreeFile
Open strFile For Input As #hFile
On Error Resume Next
For c = 1 To lCols
Input #hFile, strTemp
If c = 1 Then
strResult = strTemp
Else
strResult = strResult & ", " & strTemp
End If
Next c
Close #hFile
GetFieldsFromText = strResult
End Function
Sub OpenConnection(strConnString As String)
If oADOTextConn Is Nothing Then
Set oADOTextConn = CreateObject("ADODB.Connection")
End If
If oADOTextConn.State = 0 Then
oADOTextConn.Open strConnString
End If
End Sub
Function ExecuteAction(strCommand As String) As Long
On Error GoTo ERROROUT
oADOTextConn.Execute strCommand, ExecuteAction, 128 'adExecuteNoRecords
Exit Function
ERROROUT:
MsgBox Err.Description, , "Error in Function ExecuteAction"
End Function
Function OpenTextFileToArray(ByRef txtFile As String, _
ByRef arr As Variant, _
ByVal LBRow As Long, _
ByVal UBRow As Long, _
ByVal LBCol As Long, _
ByVal UBCol As Long, _
Optional ByRef bSkipFields As Boolean) As
Variant
Dim hFile As Long
Dim r As Long
Dim c As Long
Dim varWaste
hFile = FreeFile
Open txtFile For Input As #hFile
On Error Resume Next
If bSkipFields = False Then
For r = LBRow To UBRow
For c = LBCol To UBCol
Input #hFile, arr(r, c)
Next
Next
Else
For c = LBCol To UBCol
Input #hFile, varWaste
Next
For r = LBRow To UBRow
For c = LBCol To UBCol
Input #hFile, arr(r, c)
Next
Next
End If
Close #hFile
OpenTextFileToArray = arr
End Function
Function OpenTextFileToString3(ByVal strFile As String) As String
Dim hFile As Long
On Error GoTo ERROROUT
hFile = FreeFile
Open strFile For Binary As #hFile
OpenTextFileToString3 = Space(LOF(hFile))
Get hFile, , OpenTextFileToString3
Close #hFile
Exit Function
ERROROUT:
If hFile > 0 Then
Close #hFile
End If
End Function
I know it is a lot of code, but I find it can be quite fast, but haven't
compared with sorting in a sheet.
A better (faster) option might be to use the function HSort in the xll that
is made freely available by Laurent Longre:
http://xcell05.free.fr/morefunc/english/index.htm
A third option will be to adapt a QuickSort array sorting function. All the
ones I have seen work on one column only, but it
shouldn't be that much trouble to adapt for multiple columns.
RBS
