Creating a recordset over a range

[Guest]

All,

Would be grateful for any help on the following...

I need to create a recordset over an excel range and use bits of it (i.e.
SELECT DISTINCT ColOneName FROM rst) as the source for lists on a user form.
Have tried creating the fields and iterating through each row to create it
but it takes too long. Any ideas?

Thanks in advance,

James

 

[Dick Kusleika]

James

You can put the range in an ADO recordset, or so I've heard, but I also hear
that it's very unstable. One thing that you might try is putting the range
in an array and looping through the array instead of the range.

Dim vaRst as Variant

vaRst = Sheet1.Range("A1100").Value

Now you will have a variant array with all the values in that range.
vaRst(row,column) will let you access those values in your algorithm without
the slow-down of accesing the spreadsheet.

 

[Tim Williams]

Try this as an approach to using SQL to query data local to the
workbook. Should allow you to use SQL against a column/table range
which has headers. Need to add a reference to ADO in the project.

If you know SQL it's a quick way to get some otherwise tricky things
done.

Tim.


'#############################
Option Explicit


Sub Tester()

Dim rs As ADODB.Recordset
Dim iRow As Integer
Dim sSQL As String

sSQL = "select distinct(col2) as v"
Set rs = GetRecords(Selection, sSQL)



If Not rs Is Nothing Then
If Not rs.EOF And Not rs.BOF Then
ActiveSheet.Range("A20").CopyFromRecordset rs
Else
MsgBox "No records found"
End If
End If

End Sub



Function GetRecords(rng As Range, sSQL As String) As ADODB.Recordset
Const S_TEMP_TABLENAME As String = "SQLtempTable"
Dim oConn As New ADODB.Connection
Dim oRS As New ADODB.Recordset
Dim sPath

'name the selected range
On Error Resume Next
ActiveWorkbook.Names.Item(S_TEMP_TABLENAME).Delete
If Err.Number <> 0 Then Err.Clear

On Error GoTo haveError
ActiveWorkbook.Names.Add Name:=S_TEMP_TABLENAME, RefersToLocal:=rng

sPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sPath & _
";Extended Properties=""Excel 8.0;HDR=Yes"""


oRS.Open sSQL & " from " & S_TEMP_TABLENAME, oConn
Set GetRecords = oRS
Exit Function

haveError:
MsgBox Err.Description
Set GetRecords = Nothing



End Function

 

[Tim Williams]

Realised my first example did not allow SQL after the table name...

This is a better version.

Tim.

'###############################
Option Explicit


Sub Tester()

Dim rs As ADODB.Recordset
Dim iRow As Integer
Dim sSQL As String

sSQL = "select col2, count(col2) as v from @ group by col2"
Set rs = GetRecords(Selection, sSQL)



If Not rs Is Nothing Then
If Not rs.EOF And Not rs.BOF Then
ActiveSheet.Range("A20").CopyFromRecordset rs
Else
MsgBox "No records found"
End If
End If

End Sub



Function GetRecords(rng As Range, sSQL As String) As ADODB.Recordset
Const S_TEMP_TABLENAME As String = "SQLtempTable"
Dim oConn As New ADODB.Connection
Dim oRS As New ADODB.Recordset
Dim sPath

'name the selected range
On Error Resume Next
ActiveWorkbook.Names.Item(S_TEMP_TABLENAME).Delete
If Err.Number <> 0 Then Err.Clear

On Error GoTo haveError
ActiveWorkbook.Names.Add Name:=S_TEMP_TABLENAME, RefersToLocal:=rng

sPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sPath & _
";Extended Properties=""Excel 8.0;HDR=Yes"""


oRS.Open Replace(sSQL, "@", S_TEMP_TABLENAME), oConn
Set GetRecords = oRS
Exit Function

haveError:
MsgBox Err.Description
Set GetRecords = Nothing



End Function