View Code Snippet

Author: Osho Arun
Date Submitted: 8/22/2007
Category: Database
Compatibility: VB 6
This code has been accessed 7159 times.

Task: Will copy the information from access to ms excel according to the recordset u specify....!!!!! You can define ur recordset as per your wish...!! So easy.. Just change the query according to yourneed

Declarations

Code

Private Sub command1_Click() Dim query As String Dim excel_app As Object Dim excel_sheet As Object Dim row As Long Dim statement As String Dim col As Integer DoEvents Set excel_app = CreateObject("Excel.Application") excel_app.Visible = True excel_app.workbooks.Add If Val(excel_app.Application.Version) >= 8 Then Set excel_sheet = excel_app.ActiveSheet Else Set excel_sheet = excel_app End If Set objconn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") Set objcmd = CreateObject("ADODB.Command") objconn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _ App.Path & "\sample.mdb;Persist Security Info = False " objcmd.CommandType = adCmdText query="select * from tablename" 'HERE CHANGE UR QUERY ACCORDINGLY rs.Open (query), objconn, adOpenDynamic, adLockOptimistic For col = 0 To rs.Fields.Count - 1 excel_sheet.Cells(1, col + 1) = rs.Fields(col).Name Next col row = 2 Do While Not rs.EOF For col = 0 To rs.Fields.Count - 1 excel_sheet.Cells(row, col + 1) = _ rs.Fields(col).Value Next col row = row + 1 rs.MoveNext Loop excel_sheet.Range( _ excel_sheet.Cells(1, 1), _ excel_sheet.Cells(1, _ rs.Fields.Count)).Columns.AutoFit rs.Close Set rs = Nothing objconn.Close Set objconn = Nothing excel_sheet.rows(1).Font.Bold = True excel_sheet.rows(2).Select excel_app.ActiveWindow.FreezePanes = True excel_sheet.Cells(1, 1).Select excel_app.ActiveWorkbook.Close excel_app.Quit Set excel_sheet = Nothing Set excel_app = Nothing Screen.MousePointer = vbDefault MsgBox "Copied " & Format$(row - 2) & " values." End Sub