CopyRecordset, how to use to transfer query results from grid to Excel

[alvin777]

Hi, how do you use CopyRecordset to transfer query results from grid to Excel? It must first check if Excel exists then transfers and launches the whole Excel app. If the Excel app is already open it just transfers it to a new worksheet.

Also, a problem on grid. There are two grids one for the items called grd and the other is for its subtotal called grdSub. When grd returns a query it calculates the subtotal and it displayed on grdSub. The problem is when there is no query result the grdSub's subtotal is still there. grdSub should be blank because there was no query returned and therefore no subtotal.

Thank you in advance.

God bless,
Alvin

[Beacon]

1)

Option Explicit
 
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
 
Private Sub cmdExport_Click()
 
rs.Open "Select * From table Where fieldname ='" & uname & "", cn, adOpenKeyset, adLockPessimistic, adCmdText
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim tempStr As Integer
 
intMaxCol = rs.Fields.Count
If rs.RecordCount > 0 Then
rs.MoveLast: rs.MoveFirst
intMaxRow = rs.RecordCount
tempStr = rs.RecordCount
Set objXL = New Excel.Application
With objXL
.Visible = True
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)
 
Dim f As Field, fCount As Integer, FieldStart As Range
Set FieldStart = objWkb.Worksheets(1).Range("A1")
For Each f In rs.Fields
FieldStart.Offset(0, fCount).Value = f.Name
With objXL.Cells.Font
.Name = "Arial"
.Bold = False
.Size = 9
End With
fCount = fCount + 1
Next f
With objSht
.Range(.Cells(2, 1), .Cells(intMaxRow + 1, intMaxCol + 1)).CopyFromRecordset rs
End With
.Cells(2, 1).CurrentRegion.EntireColumn.AutoFit
End With
End If
rs.Filter = ""
rs.Close
End Sub

[alvin777]

Thank you very much but there were error, starting with cn as variable not defined. I modified it and to involves SQL and date using # sign for a date range from txtFrom to txtTo (Ex 8/8/00 to 8/8/02- sya for two annual reports of items received or bought from supplier)


Option Explicit
'------------------------------
'FOR THE cmdExcel Test button to transfer to Excel

Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
______________________________
Private Sub cmdExcel_Click()

Dim d As Database
Dim rs As Recordset
Dim q As QueryTable
Set d = OpenDatabase(App.Path & "\Parts Inventory.mdb")
Set rs = d.OpenRecordset("SELECT * FROM [Receiving Table] WHERE Received BETWEEN #" & txtFrom & "# AND #" & txtTo & "#")

rs.Open "SELECT * FROM [Receiving Table] WHERE Received BETWEEN #" & txtFrom & "# AND #" & txtTo & "#", cn, adOpenKeyset, adLockPessimistic, adCmdText
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim tempStr As Integer

intMaxCol = rs.Fields.Count
If rs.RecordCount > 0 Then
rs.MoveLast: rs.MoveFirst
intMaxRow = rs.RecordCount
tempStr = rs.RecordCount
Set objXL = New Excel.Application
With objXL
.Visible = True
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)

Dim f As Field, fCount As Integer, FieldStart As Range
Set FieldStart = objWkb.Worksheets(1).Range("A1")
For Each f In rs.Fields
FieldStart.Offset(0, fCount).Value = f.Name
With objXL.Cells.Font
.Name = "Arial"
.Bold = False
.Size = 9
End With
fCount = fCount + 1
Next f
With objSht
.Range(.Cells(2, 1), .Cells(intMaxRow + 1, intMaxCol + 1)).CopyFromRecordset rs
End With
.Cells(2, 1).CurrentRegion.EntireColumn.AutoFit
End With
End If
rs.Filter = ""

rs.Close
Set d = Nothing
Set r = Nothing

End Sub

-----------------
Btw I've slved the grdSub and grdTot display problem, was simple just repeat the SQL at the beginninof the code so it find nothing and the grids follow. It sort of refresh the grids to not display anything

[Beacon]

cn is the ado connection string.

Your using DAO so it should be db i guess! You'll have to alter it.

b

[alvin777]

Hi, still says variable not defined on db.

I wonder what's the solution here. Btw, I have tested this code it works but when you click cancel when it's on the save dialog box with Book1.xls it returns an error.

This is the code I currently use ti transfer query result to Excel but it also has other problems, like it doesn't launch the whole Excel with all the tools:


Private Sub mnuFileExcel_Click()
Me.MousePointer = 11
'-------------------------------------------------------------------------------------------------------------------------
'Check first if there is a record to save
With datDummy
'strTo = txtTo.Text
sSQL = ("SELECT * FROM [Receiving Table] WHERE Received BETWEEN #" & txtFrom & "# AND #" & txtTo & "#")
.RecordSource = sSQL
.Refresh

'If no record is found
If .Recordset.RecordCount = 0 Then
intMsg = MsgBox("There is no record to save yet", vbOKOnly + vbExclamation, Empty)
Me.MousePointer = 0
Exit Sub
End If
End With
'-------------------------------------------------------------------------------------------------------------------------

Dim d As Database
Dim r As Recordset
Dim q As QueryTable
Set d = OpenDatabase(App.Path & "\Parts Inventory.mdb")
Set r = d.OpenRecordset("SELECT * FROM [Receiving Table] WHERE Received BETWEEN #" & txtFrom & "# AND #" & txtTo & "#")


Dim x As New Excel.Application

x.Application.DisplayAlerts = False
x.Visible = False

Dim w As Worksheet
x.Workbooks.Add
Set w = x.Worksheets(1)
Set q = w.QueryTables.Add(r, w.Range("A1"))
q.Refresh (True)

x.Workbooks.Application.SaveWorkspace ' ("c:\pibkrecv.xls")
x.Quit
MsgBox "It has been saved", vbInformation, Empty
'x.SaveChanges = False


Set d = Nothing
Set r = Nothing
On Error GoTo exit2

exit2:
Exit Sub
MsgBox "Error", vbInformation, "Not Saved, Excel application may not have been installed"
Me.MousePointer = 0
End Sub


God bless,
Alvin

[Ecniv]

Originally posted by Beacon

Option Explicit
 
Private Sub cmdExport_Click()
 
Dim db as database, rs as recordset
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
 
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim tempStr As Integer
Dim f As Field, fCount As Integer, FieldStart As Range
 
on error resume next
 
set db = dbengine(0)(0).opendatbase("dbpath",false,false)
set rs = db.openrecordset("sql statement")
'rs.Open "Select * From table Where fieldname ='" & uname & "", cn, adOpenKeyset, adLockPessimistic, adCmdText
 
'---- sets max records
intMaxCol = rs.Fields.Count
If rs.RecordCount > 0 Then
rs.MoveLast: rs.MoveFirst
intMaxRow = rs.RecordCount
tempStr = rs.RecordCount
 
'---- open excel and get objects - [i]sheet[/i]
Set objXL = New Excel.Application
With objXL
.Visible = True
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)
 
'---- deals with fonts - although you could do this with .cells and format property... ;) just an idea
Set FieldStart = objWkb.Worksheets(1).Range("A1")
For Each f In rs.Fields
FieldStart.Offset(0, fCount).Value = f.Name
With objXL.Cells.Font
.Name = "Arial"
.Bold = False
.Size = 9
End With
fCount = fCount + 1
Next f
 
'---- drops the recordset into excel
With objSht
.Range(.Cells(2, 1), .Cells(intMaxRow + 1, intMaxCol + 1)).CopyFromRecordset rs
End With
.Cells(2, 1).CurrentRegion.EntireColumn.AutoFit
End With
End If
rs.Filter = ""
rs.Close
 
set rs = nothing
set db = nothing
End Sub

I've added some notes in there and amended (quickly) to what I think should work - no guarentees but should give you a start on the right code using beacons coding



Vince

[alvin777]

Hi, there's method not found error. here is the whole code now replaced with App.Path and SQL for my project. Other than those two, I did no more modification.

God bless, Alvin
_____________

Dim db As Database, rs As Recordset
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet

Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim tempStr As Integer
Dim f As Field, fCount As Integer, FieldStart As Range

On Error Resume Next

Set db = DBEngine(0)(0).OpenDatabase(App.Path & "\Parts Inventory.mdb", False, False)
Set rs = db.OpenRecordset("SELECT [RR No], Sum([Quantity x Price])AS [Subtotal] FROM [Receiving Table]WHERE Received BETWEEN #" & txtFrom.Text & "# AND #" & txtTo.Text & "#")
'rs.Open "Select * From table Where fieldname ='" & uname & "", cn, adOpenKeyset, adLockPessimistic, adCmdText

'---- sets max records
intMaxCol = rs.Fields.Count
If rs.RecordCount > 0 Then
rs.MoveLast: rs.MoveFirst
intMaxRow = rs.RecordCount
tempStr = rs.RecordCount

'---- open excel and get objects - sheet
Set objXL = New Excel.Application
With objXL
.Visible = True
Set objWkb = .Workbooks.Add
Set objSht = objWkb.Worksheets(1)

'---- deals with fonts - although you could do this with .cells and format property... just an idea
Set FieldStart = objWkb.Worksheets(1).Range("A1")
For Each f In rs.Fields
FieldStart.Offset(0, fCount).Value = f.Name
With objXL.Cells.Font
.Name = "Arial"
.Bold = False
.Size = 9
End With
fCount = fCount + 1
Next f

'---- drops the recordset into excel
With objSht
.Range(.Cells(2, 1), .Cells(intMaxRow + 1, intMaxCol + 1)).CopyFromRecordset rs
End With
.Cells(2, 1).CurrentRegion.EntireColumn.AutoFit
End With
End If
rs.Filter = ""
rs.Close

Set rs = Nothing
Set db = Nothing