William
This is not my code but here goes
Option Explicit
Option Base 0
'The subroutines in this file utilize ADO for database access - you must
'have ADO 1.5 configured on your machine for them to operate properly.
Public Type DistributorData
dDistributor As String
dDistributorID As Long
dContactName As String
dAddress As String
dCity As String
dCountry As String
dRegion As String
dPostalCode As String
dPhone As String
End Type
'Proc14 below provides an example of using the GetRows method
'of the Recordset object to obtain a result array from a ADO recordset.
'The result array is then place on the worksheet - but the array is
'first transposed using the Transpose method of the Application object
'Be careful in using the Transpose method, as if your array gets too big,
'the method will fail.
Sub Proc14_CopyToRange_ADO()
Dim Rs1 As ADODB.Recordset
Set Rs1 = New ADODB.Recordset
Rs1.Open Source:="Distributors", _
ActiveConnection:="DBQ=" & ThisWorkbook.Path & "\SAMPDATA.MDB;" & _
"Driver={Microsoft Access Driver (*.mdb)};", _
CursorType:=adOpenStatic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
With Worksheets("ADOSheet"

.Range("A1"

.CurrentRegion.Clear
Application.Intersect(.Range(.Rows(1), .Rows(Rs1.RecordCount)), .Range(.Columns(1), .Columns(Rs1.Fields.Count))).Value = Application.Transpose(Rs1.GetRows(Rs1.RecordCount))
End With
Rs1.Close
End Sub
'Proc15 below is similar in nature to Proc14 above, however, in this
'case the result array which is returned by the GetRows method of the
'recordset object is too big for us to use the Transpose method. So
'in the case, we employ a custom VBA function (see below) called TransposeArray
'which does nothing other than transpose the array.
Sub Proc15_CopyToRange2_ADO()
Dim Rs1 As ADODB.Recordset
Set Rs1 = New ADODB.Recordset
Rs1.Open Source:="Query1", _
ActiveConnection:="DBQ=" & ThisWorkbook.Path & "\SAMPDATA.MDB;" & _
"Driver={Microsoft Access Driver (*.mdb)};", _
CursorType:=adOpenStatic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
With Worksheets("ADOSheet"

.Range("A1"

.CurrentRegion.Clear
Application.Intersect(.Range(.Rows(1), .Rows(Rs1.RecordCount)), .Range(.Columns(1), .Columns(Rs1.Fields.Count))).Value = TransposeArray(Rs1.GetRows(Rs1.RecordCount))
End With
Rs1.Close
End Sub
Function TransposeArray(ByRef Array1 As Variant) As Variant
Dim x As Integer
Dim y As Integer
Dim q As Integer
Dim r As Integer
Dim Array2() As Variant
x = UBound(Array1, 1)
y = UBound(Array1, 2)
ReDim Array2(y, x)
For q = 0 To x
For r = 0 To y
Array2(r, q) = Array1(q, r)
Next
Next
TransposeArray = Array2
End Function
'Proc16 provides an example of writing Excel worksheet data to an
'Access database via ADO. The process involves first opening a
'recordset, then calling the AddNew method. You then set the values of
'the various fields, and lastly call Update.
Sub Proc16_WritingWorksheetData_ADO()
Dim Range1 As Range
Dim Array1 As Variant
Dim x As Variant
Dim Rs1 As ADODB.Recordset
Set Rs1 = New ADODB.Recordset
Rs1.Open Source:="Distributors", _
ActiveConnection:="DBQ=" & ThisWorkbook.Path & "\SAMPDATA.MDB;" & _
"Driver={Microsoft Access Driver (*.mdb)};", _
CursorType:=adOpenStatic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
Set Range1 = ThisWorkbook.Worksheets("Distributors"

.Range("A1"

.CurrentRegion.Offset(1, 0)
Set Range1 = Range1.Resize(Range1.Rows.Count - 1, Range1.Columns.Count)
Worksheets("Distributors"

.Select
Range1.Select
'Read the worksheet range into an array.
Array1 = Range1.Value
'Then write the data from the array to the recordset.
'Note that for each new record, you must first call Addnew
'then set the value property of the fields, and then call Update.
For x = 1 To UBound(Array1, 1)
With Rs1
.AddNew
.Fields("DistributorID"

= Array1(x, 1)
.Fields("Distributor"

= Array1(x, 2)
.Fields("ContactName"

= Array1(x, 3)
.Fields("Address"

= Array1(x, 4)
.Fields("City"

= Array1(x, 5)
.Fields("Country"

= Array1(x, 6)
.Fields("Region"

= Array1(x, 7)
.Fields("PostalCode"

= Array1(x, 8)
.Fields("Phone"

= Array1(x, 9)
.Update
End With
Next
Rs1.Close
End Sub
Regards
Jason