VBA retrieve data(with criteria) from Access Query, Range error

[daun]

Hi,

I am using a vba macro in order to retrieve data from an access query, it worked just fine until I tried to gather data that was more than 200 rows. When I did that I got the following error: "Run-time error '-2147467259 (80004005)': Method 'CopyFromRecordset' of object 'Range' failed.
And it stops pasting data at row 203 or something similar.
I would guess there is some kind of data overflow, but I would think that it only was 65000 rows limit.

The second Macro (CustReport_No_Criteria) was recorded and works even better, it brings all the needed rows But, and it is a bit But, I can not figure out a way to enter Parameters/Criteria in to that query.

Help to get any of these macros working would really help me alot. (The thing is that I have a lot of queries in MS Access that are already finished and quite advanced but I do no want other people that dont have access knowledge to go into the access database, thus I want to run the query with changeble critera from Excel)

Thank you in advance.


Sub CustReport_Criteria()

'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer

'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
("C:\Access\Customerreport.mdb")
Set MyQueryDef = MyDatabase.QueryDefs("Report per Custnr")


'Step 3: Define the Parameters
With MyQueryDef
.Parameters("[Custnr]") = Range("A1").Value 'Have the critera of the cell Custnr in Access set to [Custnr]. The Critera works
End With

'Step 4: Open the query
Set MyRecordset = MyQueryDef.OpenRecordset

'Step 5: Clear previous contents
Sheets("Sheet1").Select
ActiveSheet.Range("A2:Q65000").ClearContents

'Step 6: Copy the recordset to Excel
ActiveSheet.Range("B3").CopyFromRecordset MyRecordset

'Step 7: Add column heading names to the spreadsheet

For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(2, 1 + i).Value = MyRecordset.Fields(i - 1).Name
Next i


MsgBox "Your Query has been Run"

End Sub





Sub CustReport_No_Criteria()

Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\Access\Customerreport.mdb;Mode" _
, _
"=ReadWrite;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLE" _
, _
"DB:Engine Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet " _
, _
"OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Loca" _
, _
"le on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("Report per Custnr")
'.Parameters("Custnr") = "Customer"
.Name = "Customerreport" 'Doesnt Work Gets error Runtime error 9 Subscript out of range
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\Access\Customerreport.mdb"
.Refresh BackgroundQuery:=False
End With
End Sub