The three Modules below get data from an Access database and place it in an Excel sheet
and return data from an Excel sheet, appending it to the Access database.
Sub GetData()
Dim rsDemoData As ADODB.Recordset
Set rsDemoData = New ADODB.Recordset
rsDemoData.Open Source:="MostRecentRecord" ActiveConnection:="Provider=Microsoft.Jet.OLEDB.4.0;
Data Source=D:\Program Files\Microsoft Office\Office\Samples\DemoData.mdb" CursorType:=adOpenStatic LockType:=adLockOptimistic, Options:=adCmdTable
rsDemoData.Filter = "[PersonID] = " & Worksheets("Sheet1").Range("A5")
With Worksheets("Sheet2")
.Range("A1").CurrentRegion.Clear
Application.Intersect(.Range(.Rows(1), .Rows(rsDemoData.RecordCount)),
.Range(.Columns(1), .Columns(rsDemoData.Fields.Count))).
Value = MyTranspose(rsDemoData.GetRows(rsDemoData.RecordCount))
End With
rsDemoData.Close
End Sub
Function MyTranspose(ByRef ArrayOriginal As Variant) As Variant
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim j As Integer
Dim ArrayTranspose As Variant
x = UBound(ArrayOriginal, 1)
y = UBound(ArrayOriginal, 2)
ReDim ArrayTranspose(y, x)
For i = 0 To x
For j = 0 To y
ArrayTranspose(j, i) = ArrayOriginal(i, j)
Next
Next
MyTranspose = ArrayTranspose
End Function
Sub PutData()
Dim rsDemoData As ADODB.Recordset
Set rsDemoData = New ADODB.Recordset
rsDemoData.Open Source:="AllRecords", ActiveConnection:="Provider=Microsoft.Jet.OLEDB.4.0;
Data Source=D:\Program Files\Microsoft Office\Office\Samples\DemoData.mdb" CursorType:=adOpenStatic LockType:=adLockOptimistic, Options:=adCmdTable
rsDemoData.AddNew
rsDemoData![PersonID] = Worksheets("Sheet1").Range("A5")
rsDemoData![Value1] = Worksheets("Sheet1").Range("B5")
rsDemoData![Comment1] = Worksheets("Sheet1").Range("C5")
rsDemoData![Value2] = Worksheets("Sheet1").Range("D5")
rsDemoData![Value3] = Worksheets("Sheet1").Range("E5")
rsDemoData.Update
rsDemoData.Close
End Sub
Prepared by : George Herrick, Herrick Brown & Company Ltd.
PO Box 21, Eccles, Manchester. M30 7BN. 0161 925 0600.
e-mail : mail<at>herrick-brown.co.uk where <at> = @
If you find them to be useful, let us know by e-mail. Thanks.