converting Excel.Worksheet.Range in to ADODB.Recordset

[Mirco Wilhelm]

Hi all,

I'm trying to import an Excel Worksheet Range into an Access Recordset, but
i can't figure out how to handle this type of data.

This copies the values to the clipboard

strExcelRange = "A1:A10"
objExcelSheet.Range(strExcelRange).Copy

and when i paste it to notepad i get this output:

1 a A
2 b B
3 c C
4 d D
5 e E
6 f F
7 g G
8 h H
9 i I
10 j J

All i need to do now is to get these values into a ADODB.Recordset, but i
have to give this output to another data type first, which i haven't figured
out yet.

objExcelSheet.Range(strExcelRange).Copy NewVariable

I tried a String Array, ADODB.Recordset and even a Excel.Range, but
everytime i got the message "Invalid procedure call or argument".

Any Ideas how to do this right?

 

[John Nurick]

Hi Mirco,

Excel's Range.Copy can only copy to another Excel range or the
clipboard. Instead, do something like this:

Dim raR as Excel.Range
Dim rsT as ADODB.Recordset
Set raR = objExcelSheet.Range("A1:C10")
Set rsT = blah blah blah

For Each R in raR.Rows
rsT.AddNew
For j = 1 to R.Cells.Count
rsT.Fields(j).Value = R.Cells(j).Value
Next
rsT.Update
Next

Alternatively, import or link the Excel range to an Access table and
open a recordset on that.

 

[Mirco Wilhelm]

Excel's Range.Copy can only copy to another Excel range or the

clipboard. Instead, do something like this:

Dim raR as Excel.Range
Dim rsT as ADODB.Recordset
Set raR = objExcelSheet.Range("A1:C10")
Set rsT = blah blah blah

For Each R in raR.Rows
rsT.AddNew
For j = 1 to R.Cells.Count
rsT.Fields(j).Value = R.Cells(j).Value
Next
rsT.Update
Next

Alternatively, import or link the Excel range to an Access table and
open a recordset on that.

Ok, tried that, but couldn't figure out what Type R and J are of. Second
thing is how to store the data in a Recordset without writign it to the
table with .addNew, since i want to return the whole set to the caller.

Public Function GetRSFromExcel( _
ByVal strExcelFile As String, _
ByVal strFirstFieldID As String, _
ByVal strLastFieldID As String, _
ByVal intExcelWorksheet As Integer) _
As dao.Recordset

On Error GoTo GetRSFromExcel_Error

'---------------------------------------------------------------------------
--------------
' Import an Excel Workbook into an Access Recordset
'
' example call: srcExcelRecordSet = GetRSFromExcel("test.xls","A1","A10",1)
' ^ ^ ^ ^ ^
' | | | | |
' returned recordset Filename, start, end,
sheetnumber
'---------------------------------------------------------------------------
--------------

Dim objExcel As New Excel.Application
Dim objExcelWorkbook As Excel.workbook
Dim objExcelSheet As Excel.Worksheet
Dim objExcelRange As Excel.Range

Dim i As Integer
Dim strExcelRange As String, strSelectRange As String

' open excel file
Set objExcelWorkbook = objExcel.Workbooks.Open(strExcelFile)
Debug.Print "öffnen von: " & strExcelFile

' make invisible and block userinput
objExcel.Visible = False
objExcel.Interactive = False
Debug.Print "ausblenden von Excel"

' set reference to a worksheet
Set objExcelSheet = objExcelWorkbook.Sheets(intExcelWorksheet)

' disable display refresh
objExcel.ScreenUpdating = False

' read recordset
strExcelRange = strFirstFieldID & ":" & strLastFieldID
Set objExcelRange = objExcelSheet.Range(strExcelRange)

For Each R In objExcelRange.Rows
GetRSFromExcel.AddNew

For J = 1 To J.Cells.Count
GetRSFromExcel.Fields(i).Value = R.Cells(i).Value
Next

GetRSFromExcel.Update
Next

' activate display refresh
objExcel.ScreenUpdating = True

' activate user input
objExcel.Interactive = True

objExcelWorkbook.Close
objExcel.Quit

' destroy object references
Set objExcelSheet = Nothing
Set objExcel = Nothing

Exit Function

GetRSFromExcel_Error:

End Function

 

[John Nurick]

Ok, tried that, but couldn't figure out what Type R and J are of. Second
thing is how to store the data in a Recordset without writign it to the
table with .addNew, since i want to return the whole set to the caller.

R is an Excel.Range, j is a Long.

The second thing I can't help you with as I seldom use ADO. Perhaps it's
possible to do it by using an ODBC connection to the Excel workbook.

 

[onedaywhen]

The amended code (below) fabricates a disconnection ADODB recordset.
The AddNew method add a new row to the recordset, not a table. I have
hard coded to find three multi-space delimited values (integer,
string, string) in a single Excel cell.

Sub test()

Dim rsTest As ADODB.Recordset

Set rsTest = GetRSFromExcel("C:\Tempo\test.xls", "A1", "A10", 1)

Set rsTest = Nothing

End Sub

Public Function GetRSFromExcel(ByVal ExcelFile As String, _
ByVal FirstFieldID As String, _
ByVal LastFieldID As String, _
ByVal ExcelWorksheet As Long) _
As ADODB.Recordset

On Error GoTo GetRSFromExcel_Error

'---------------------------------------------------------------------------
' Import an Excel Range into an ADODB Recordset
'
' example call: srcExcelRecordSet =
GetRSFromExcel("test.xls","A1","A10",1)
' ^ ^ ^ ^
^
' | | | |
|
' returned recordset Filename, start,
end, sheet
'---------------------------------------------------------------------------

Dim objExcel As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelSheet As Excel.Worksheet
Dim objExcelRange As Excel.Range
Dim objExcelTempRange As Excel.Range
Dim strExcelRange As String

Dim objRS As ADODB.Recordset

' create new excel application
Set objExcel = New Excel.Application

' open excel file
Set objExcelWorkbook = objExcel.Workbooks.Open(ExcelFile)
Debug.Print "öffnen von: " & ExcelFile

' make invisible and block userinput
objExcel.Visible = False
objExcel.Interactive = False
Debug.Print "ausblenden von Excel"

' set reference to a worksheet
Set objExcelSheet = objExcelWorkbook.Sheets(ExcelWorksheet)

' disable display refresh
objExcel.ScreenUpdating = False

' read recordset
strExcelRange = FirstFieldID & ":" & LastFieldID
Set objExcelRange = objExcelSheet.Range(strExcelRange)

' create new recordset
Set objRS = New ADODB.Recordset

With objRS

.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockBatchOptimistic

.Fields.Append "Col1", adInteger
.Fields.Append "Col2", adVarChar, 1
.Fields.Append "Col3", adVarChar, 1

.Open

End With

For Each objExcelTempRange In objExcelRange.Cells

AddToRS objExcelTempRange.Value, objRS

Next

' activate display refresh
objExcel.ScreenUpdating = True

' activate user input
objExcel.Interactive = True

objExcelWorkbook.Close
objExcel.Quit

' destroy object references
Set objExcelSheet = Nothing
Set objExcel = Nothing

Set GetRSFromExcel = objRS

Exit Function

GetRSFromExcel_Error:

End Function

Private Function AddToRS(ByVal CellContents As String, _
ByVal RS As ADODB.Recordset) As Boolean

Dim vntArray As Variant

vntArray = Split(Excel.WorksheetFunction.Trim(CellContents), " ")

With RS
.AddNew
.Fields(0).Value = vntArray(0)
.Fields(1).Value = vntArray(1)
.Fields(2).Value = vntArray(2)
End With

AddToRS = True

End Function