Can you create an ADO recordset from an array 3

[SBendBuckeye]

I need to do multiple sorts on an array. Is there a way to create an ADO recordset from it? This would enable me to use the Recordset.Sort method and greatly simplify things.

Thanks in advance for any ideas and/or suggestions!

Have a great day!

j2consulting@yahoo.com

 

[Zion7]

Good question SBendBuckeye, I've seen it a few times now.

So far, the responses have always been no, to Sort the Array. Instead, the option was to create a Temp table. And then, Recordset.Sort is feasible. Re-populate array, delete temp table.

But, who knows?...

 

[Zion7]

I couldn't resist to try.
If not just for entertainment value, I will show you this...

Sub SortArray()

Dim x, z, y As Integer, sArray, sNewArray() As Variant, bLess As Boolean
sArray = Array("Kenya", "DenMark", "Japan", "Uganda", "Italy", "Malaysia", "Syria", "Holland", "Bulgaria", "Zimbabwe", _
"Canada", "Uraguay", "Lebanon", "Rhawanda", "Nepal", "Ireland", "England", "Iceland", "France", _
"Poland", "Tazmania", "Germany", "Algeria")

'...then populate a new array.
ReDim sNewArray(0 To 1)
If Asc(Left(sArray(0), 1)) > Asc(Left(sArray(1), 1)) Then
sNewArray(0) = sArray(1): sNewArray(1) = sArray(0)
Else
sNewArray(0) = sArray(0): sNewArray(1) = sArray(1)
End If

'Loop thru new array. Since it will loop lowest to highest,
'The minute sArray(2), is lower then sNewArray(x), you will know exactly where to place it.
For z = 2 To UBound(sArray)
For x = 0 To UBound(sNewArray)
If Asc(Left(sArray(z), 1)) < Asc(Left(sNewArray(x), 1)) Then
bLess = True
ReDim Preserve sNewArray(0 To UBound(sNewArray) + 1)
For y = UBound(sNewArray) - 1 To x Step -1
sNewArray(y + 1) = sNewArray
Next y
sNewArray(x) = sArray(z)
Exit For
End If
Next x
If bLess = False Then
ReDim Preserve sNewArray(0 To UBound(sNewArray) + 1)
sNewArray(x) = sArray(z)
End If

x = 0: bLess = False
Next z

x = 0
For x = 0 To UBound(sNewArray)
Debug.Print sNewArray(x)
Next x

End Sub

...Now, as you may realise, this only sorts first letter. So where 2 words start with same letter, They will sort between the other letters properly, but between themselves, there position in the array, gives precedence.

Hope you or someone else, may find this interesting!

 

[cmmrfrds]

Yes, but I don't know of any short cut to looping through the array to add the records. It would be similar to moving 1 recordset to another.

Dim arrFields As Variant 'define fields in recordset
arrFields = Array("ID", "startdate", "enddate", "gap", "gapNum")

' Move data from rs to rs1.
rs.MoveFirst
For indx = 0 To recCount - 1
rs1.AddNew arrFields, Array(rs!ID, rs!startdate, rs!enddate, 0, 0)
rs.MoveNext
Next

 

[Zion7]

SBendBuckeye,
Now this sorts up to 5 similiar letters, within 2 words.
Once you see the structure, you can go as high as you like.
Problem though, run-time error occurs if word length is not long enough for Mid() function. Example; Niger & Nigeria, Niger should come first, but error occurs on ...
Asc(Mid(sArray(z), 6, 1))
Tried Nz(), but to no avail.
I know I can use If Len(sArray(x)) = 5 ....
But, no patience this evening.

Sub SortArray()

Dim x, z, y As Integer, sArray, sNewArray() As Variant, bLess As Boolean
sArray = Array("Barbuda", "Kenya", "Denmark", "Western Sahara", "Guatemala", "Japan", "Oceania", "Zimbabwe", _
"Uraguay", "Italy", "Malaysia", "Syria", "Nigeria", "Barbados", "Qatar", "Holland", "Bulgaria", _
"Canada", "Uganda", "Lebanon", "Rwanda", "Nepal", "Ireland", "England", "Iceland", "France", _
"Yemin", "Peru", "Guadeloupe", "Taiwan", "Germany", "Taipan", "Niger", "Cambodia", "Vietnam", "Algeria")

'...then populate a new array.
ReDim sNewArray(0 To 1)
If Asc(Left(sArray(0), 1)) > Asc(Left(sArray(1), 1)) Then
sNewArray(0) = sArray(1): sNewArray(1) = sArray(0)
Else
sNewArray(0) = sArray(0): sNewArray(1) = sArray(1)
End If

'Loop thru new array. Since it will loop lowest to highest,
'The minute sArray(2), is lower then sNewArray(x), you will know exactly where to place it.
For z = 2 To UBound(sArray)
For x = 0 To UBound(sNewArray)

If Asc(Left(sArray(z), 1)) = Asc(Left(sNewArray(x), 1)) Then
If Asc(Mid(sArray(z), 2, 1)) < Asc(Mid(sNewArray(x), 2, 1)) Then
GoTo Less
ElseIf Asc(Mid(sArray(z), 2, 1)) = Asc(Mid(sNewArray(x), 2, 1)) Then
If Asc(Mid(sArray(z), 3, 1)) < Asc(Mid(sNewArray(x), 3, 1)) Then
GoTo Less
ElseIf Asc(Mid(sArray(z), 3, 1)) = Asc(Mid(sNewArray(x), 3, 1)) Then
If Asc(Mid(sArray(z), 4, 1)) < Asc(Mid(sNewArray(x), 4, 1)) Then
GoTo Less
ElseIf Asc(Mid(sArray(z), 4, 1)) = Asc(Mid(sNewArray(x), 4, 1)) Then
If Asc(Mid(sArray(z), 5, 1)) < Asc(Mid(sNewArray(x), 5, 1)) Then GoTo Less Else GoTo Continue
End If
End If
End If
End If



If Asc(Left(sArray(z), 1)) < Asc(Left(sNewArray(x), 1)) Then
Less:
bLess = True
ReDim Preserve sNewArray(0 To UBound(sNewArray) + 1)
For y = UBound(sNewArray) - 1 To x Step -1
sNewArray(y + 1) = sNewArray 'reAdjust all "higher than x" elements in array, make room for new element
Next y
sNewArray(x) = sArray(z) 'Assign new element, to current position of new Array
Exit For 'no need to continue looping
End If
Continue:
Next x
If bLess = False Then
ReDim Preserve sNewArray(0 To UBound(sNewArray) + 1)
sNewArray(UBound(sNewArray)) = sArray(z) 'append to Ubound of Array
End If

x = 0: bLess = False

Next z

x = 0
For x = 0 To UBound(sNewArray)
Debug.Print x & ": " & sNewArray(x)
Next x

End Sub

 

[DanJR]

SBendBuckeye,

Is the array one-dimensional or muli-dimensional?
Is the array always of one data type? e.g. string / integer etc?

When you mean "do muliple sorts" are you referring to sorting both by ascending or descending or being able to sort different columns of the array or both?

Why not implement a QuickSort algorithm and encapsulate it in a class module? e.g. something like:

Option Compare Database
Option Explicit

Private Function QuickSortR(a() As String, low As Long, high As Long)
  Dim middle  As Long
  Dim pivot   As String
  Dim i       As Long
  Dim j       As Long
  
  ' Sort low, middle, high
  middle = (low + high) / 2
  If a(middle) < a(low) Then Call SwapReferences(a, low, middle)
  If a(high) < a(low) Then Call SwapReferences(a, low, high)
  If a(high) < a(middle) Then Call SwapReferences(a, middle, high)
  
  ' base case
  If high - low < 2 Then Exit Function
  
  ' Place pivot at position high-1
  Call SwapReferences(a, middle, high - 1)
  pivot = a(high - 1)
  
  ' Begin partitioning
  j = high - 1
  i = low
  
  Do
    Do
      i = i + 1
    Loop While (a(i) < pivot)
    Do
      j = j - 1
    Loop While (pivot < a(j))
    
    If i < j Then
      Call SwapReferences(a, i, j)
    Else
      Exit Do
    End If
 Loop
  
  ' Restore pivot
  Call SwapReferences(a, i, high - 1)
  Call QuickSortR(a, low, i - 1) ' sort small elements
  Call QuickSortR(a, i + 1, high) ' sort large elements
  
  
End Function

Public Function QuickSort(a() As String)
  Call QuickSortR(a, 0, UBound(a))
End Function

Private Function SwapReferences(a() As String, low As Long, high As Long)
  Dim tmp As String
  
  tmp = a(high)
  a(high) = a(low)
  a(low) = tmp
  
End Function

A quicksort can run in O(N log N) time

If the array is multi-dimensional then you could adapt it to use the following prototypes:

Private Function QuickSortR(a() As String, ColumnIndex As Long, low As Long, high As Long)
Public Function QuickSort(a() As String, ColumnIndex As Long)

If the array columns are both numeric and string then you could use Object instead of string(?) or create separate sort routines for each data type.

Although i wrote the above code, I adapted it from one of my data structure books in Java. I haven't thoroughly tested it!

The implementation thus becomes simple:

Dim objSort As clsQuickSort
Set objSort = New clsQuickSort
Call objSort.QuickSort(myArray)

Cheers,
Dan

 

[PHV]

SBendBuckeye, the short answer is yes, simply use a disconnected recordset.
Here a pointer to a Dilettante's faq in the VBScript forum:

http://www.tek-tips.com/faqs.cfm?fid=3362

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[cmmrfrds]

Here is a simple example of a disconnected recordset.


Public Function FabricatedRS()

Dim rs As ADODB.Recordset
Dim varArray As Variant
Set rs = New ADODB.Recordset

With rs.Fields
.Append "myid", adInteger
.Append "mydesc", adVarChar, 50, adFldIsNullable
End With

varArray = Array("myid", "mydesc")

With rs
.Open
.AddNew varArray, Array(1, "first desc")
.AddNew varArray, Array(2, "second desc")
.AddNew varArray, Array(3, "third desc")
.AddNew varArray, Array(4, "fourth desc")
End With
rs.MoveFirst
While Not rs.EOF
Debug.Print rs!myid; " "; rs!mydesc
rs.MoveNext
Wend

rs.Sort = "myid DESC"

rs.MoveFirst
While Not rs.EOF
Debug.Print rs!myid; " "; rs!mydesc
rs.MoveNext
Wend

rs.Filter = "myid = 3"

rs.MoveFirst
While Not rs.EOF
Debug.Print rs!myid; " "; rs!mydesc
rs.MoveNext
Wend

rs.Filter = adFilterNone

rs.Close
Set rs = Nothing

End Function

 

[SBendBuckeye]

Thanks for all of the help, ideas and suggestions! I was already aware of disconnected recordsets although I hadn't ever used them. What I was really hoping for was something like the reverse of GetRows which would build it all in 1 line of code. Oh well, maybe for a rainy day! Thanks again!

Have a great day!

j2consulting@yahoo.com

 

[Zion7]

A little belated, but Thx cmmrfrds, that was a very clear example.
...Another thread has prompted me, to look into this again.

thanks, and have a great day!

 

[cmmrfrds]

You are welcome Zion7. I am glad it was helpful.