Read/Write data to a closed workbook?

[razzandy]

I've found the below code which I think is inteded for microsoft visual studio. What I'm wondering is can it be changed to work from XL. If so I will be useing one workbook with the code and a userform to read/write data to the closed workbook as a database!

Sub Link()

Dim adoCn
Dim adoRs

Set adoCn = CreateObject("ADODB.Connection")
With adoCn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = _
"Data Source=C:\Island.xls;" & _
"Extended Properties=Excell 8.0;"
End With

Set adoRs = CreateObject("ADODB.Recordset")
strQuery = "SELECT * FROM [Sheet2$]"
With adoRs
Set .ActiveConnection = adoCn
.Open strQuery
End With
End Sub

I've already seen the examples which open one workbook and copy the data over but you may as well just include the data in the original workbook!

Thanks in advance

Ryan A UK

 

[Andrew Poulsom]

See:

http://www.erlandsendata.no/english/vba/adodao/index.php

 

[razzandy]

Hi Andrew Poulsom

Thanks for the link it's a cracking site! There just one problem I still cant get my code or any code from the website link to work!

Have you got any examples that work? Is so can you e-mail me a copy?

I think it's something to do with that ADO, do I need to install something?

Thanks for your help :D

Ryan A Uk

 

[razzandy]

Anbody else got any idea??


Cheers

Ryan A UK

 

[Andrew Poulsom]

In what way doesn't it work? Are you getting errors? If so what are they and on which line(s) of code.

 

[razzandy]

Hi Andrew

Below is the code from the web link you gave me described as: Use a closed workbook as a database (DAO) @ http://www.erlandsendata.no/english...End Sub [u][/u] Many Thanks Ryan A UK :D

 

[Andrew Poulsom]

As it says at the bottom of the sample code:

The macro examples assumes that your VBA project has added a reference to the DAO object library.
You can do this from within the VBE by selecting the menu Tools, References and selecting Microsoft DAO x.xx Object Library.

 

[razzandy]

Thanks Andrew

Sorry to sound so stupid but I’ve not delved it to this sort of code before.

That’s cleared that error, but now It’s coming up with another:

Compile error: Sub or Function not defined, this highlights ‘RS2WS’ near the bottom of the code!

I really appreciate your help!

Cheers

Ryan A UK

 

[razzandy]

Sorry Andrew

I'd not added the full code!!! Deeeeeeeeeeeeeerrrrrrrrr

It now works perfect many thanks mate!

Cheers

Ryan A UK :P :D

 

[razzandy]

Dear Andrew Poulsom if you are there??? :idea:


Do you know how TO make this code write back to the original workbook? You know if I make some changes and want to save them to the closed workbook!

This is the code I'm now using:

Sub GetWorksheetData(strSourceFile As String, strSQL As String, TargetCell As Range)
Dim db As DAO.Database, rs As DAO.Recordset, f As Integer, r As Long
If TargetCell Is Nothing Then Exit Sub

On Error Resume Next

Set db = OpenDatabase(strSourceFile, False, False, "Excel 8.0;HDR=Yes;")

On Error GoTo 0
If db Is Nothing Then
MsgBox "Can't find the file!", vbExclamation, ThisWorkbook.Name
Exit Sub
End If



' open a recordset
On Error Resume Next
Set rs = db.OpenRecordset(strSQL)

On Error GoTo 0
If rs Is Nothing Then
MsgBox "Can't open the file!", vbExclamation, ThisWorkbook.Name
db.Close
Set db = Nothing
Exit Sub
End If

RS2WS rs, TargetCell

rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub

Sub RS2WS(rs As DAO.Recordset, TargetCell As Range)
Dim f As Integer, r As Long, c As Long
If rs Is Nothing Then Exit Sub
If TargetCell Is Nothing Then Exit Sub

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.StatusBar = "Writing data from recordset..."
End With

With TargetCell.Cells(1, 1)
r = .Row
c = .Column
End With

With TargetCell.Parent
.Range(.Cells(r, c), .Cells(.Rows.Count, c + rs.Fields.Count - 1)).Clear
' clear existing contents
' write column headers
For f = 0 To rs.Fields.Count - 1
On Error Resume Next
.Cells(r, c + f).Formula = rs.Fields(f).Name
On Error GoTo 0
Next f
' write records
On Error Resume Next
rs.MoveFirst
On Error GoTo 0
Do While Not rs.EOF
r = r + 1
For f = 0 To rs.Fields.Count - 1
On Error Resume Next
.Cells(r, c + f).Formula = rs.Fields(f).Value
On Error GoTo 0
Next f
rs.MoveNext
Loop
.Rows(TargetCell.Cells(1, 1).Row).Font.Bold = True
.Columns("A:IV").AutoFit
End With

With Application
.StatusBar = False
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub


Sub getdata()
GetWorksheetData "C:\Island.xls", "SELECT * FROM [Island$]", _
ThisWorkbook.Worksheets(1).Range("A3")

End Sub

Thanks in Advance :P

Ryan A UK