By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
445,704 Members | 1,861 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 445,704 IT Pros & Developers. It's quick & easy.

ADO Excel WorkSheet Naming WorkSheet Access Database Part 2

P: n/a
Hi there

Hope this helps others
Public Function Export_Excel_10(dblocation As Variant)
On Error GoTo Err_Export_Excel_10

Dim x1 As Excel.Application
Dim excelwbkXL As Object
Dim excelwksXL As Object
Dim counter As Integer, row As Integer
Dim strSQL1 As String, strSQL4 As String
Dim strPath_Security_WkGrp As String, strPath_Security_User As String
Dim strPath_Security_Pwd As String, strPath As String
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset
Dim D As DAO.Database, R As DAO.Recordset, s As String
Dim I As Integer
Dim strTable As Integer

'***AIM-Default Settings
dblocation = "C:\WWL.PipeSpec\book1.xls"
strPath = "C:\WWL.PipeSpec\PipeSpec.mdb"
strPath_Security_WkGrp = "C:\WWL.PipeSpec\WorkGroup\wwl_sys1.mda"
strPath_Security_User = ""
strPath_Security_Pwd = ""
strTable = 0

'***AIM-Open the Excel spreadsheet.
Set x1 = CreateObject("Excel.application")
Set excelwbkXL = x1.Workbooks.Open(dblocation)

'***AIM-Display Excel and give user control of Excel
x1.Visible = True
x1.UserControl = True

'***AIM-Set the string to the path of the Working database
Set cnt = New ADODB.Connection
With cnt
.Provider = "Microsoft.Jet.OLEDB.4.0"
.CursorLocation = adUseClient
'.Properties("Jet OLEDB:Database Password") = "" --> password
.Properties("Jet OLEDB:System Database") =
strPath_Security_WkGrp
.Open strPath, strPath_Security_User, strPath_Security_Pwd
End With

s = "SELECT Table_Name FROM STANDARD_TABLES"
Set D = CurrentDb
Set R = D.OpenRecordset(s)
'***AIM-LOOP THROUGH RECORDS IN PathTextTech
Do Until R.EOF

If R!table_name = "Pass" Or R!table_name = "Timeout" Then
'
Else
strSQL1 = "select * from " & R!table_name & ";"
End If

strSQL4 = "select * from " & R!table_name & ";"
strTable = strTable + 1

Set rst = New ADODB.Recordset
rst.Open strSQL4, cnt

'***AIM-Add new sheet
Set excelwksXL = excelwbkXL.Worksheets.Add

'***AIM-Spreadsheet - sheet name
excelwksXL.NAME = R!table_name

'***AIM-Make the column headers.
For I = 1 To rst.Fields.Count - 1
excelwksXL.Cells(9, I).Value = rst.Fields(I).NAME
Next I

'***AIM-Get data from the database and insert
'***AIM-it into the spreadsheet.
row = 10
Do While Not rst.EOF
For I = 1 To rst.Fields.Count - 1
excelwksXL.Cells(row, I) = rst.Fields(I).Value
Next I

row = row + 1
rst.MoveNext
Loop

'***AIM-Need to disable, can't handle large number of rows
(2000>)
'***AIM-Formatting
'excelwksXL.range(excelwksXL.Cells(1, 1), _
'excelwksXL.Cells(1, row)).Select
'x1.Selection.EntireColumn.AutoFit
'X1.Selection.Columns.AutoFit

R.MoveNext
Loop
R.Close
D.Close

Set excelwbkXL = Nothing
Set excelwksXL = Nothing

'***AIM-End Message
msgbox "Transfered over " & strTable & " tables out of 33 in
total.", vbInformation

Exit_Export_Excel_10:
Exit Function

Err_Export_Excel_10:
msgbox ERR.Description
Resume Exit_Export_Excel_10

End Function
Nov 12 '05 #1
Share this question for a faster answer!
Share on Google+

This discussion thread is closed

Replies have been disabled for this discussion.