Hi there
Have a database, where front-end interface allows user to select a ms
access database. From there, standard tables are linked. Routine,
that creates a spreadsheet, for each table a separate sheet within
spreadsheet is created. Particular fields are selected.
User requires fields to be auto-fitted. Problem, is that some tables
have more than 1200> rows. Code generates error message. Is there a
way of getting around this problem. See ***
Code -->
Public Function Export_Excel_10 (dblocation As Variant)
On Error GoTo Err_Export_Exce l_10
'***AIM-Testing
'CALL Export_Excel_10 ("T:\TechCentra l\techCENTRAL\S tdSpecs\WWL\A00 00.MDB")
Dim x1 As Excel.Applicati on
Dim excelwbkXL As Object
Dim excelwksXL As Object
Dim counter As Integer, row As Integer
Dim strSQL1 As String, strSQL4 As String
Dim strSQL4A As String, strSQL4B As String, strSQL4C As String,
strSQL4D As String
Dim strSQL4E As String, strSQL4F As String, strSQL4G As String,
strSQL4H As String
Dim strPath_Securit y_WkGrp As String, strPath_Securit y_User As String
Dim strPath_Securit y_Pwd As String, strPath As String
Dim cnt As New ADODB.Connectio n, 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
Dim posLONG_DESCR As Integer, posMAIN_SIZE As Integer, posRUN_SIZE As
Integer, posBRAN_SIZE As Integer
Dim posSCHEDULE As Integer, posRATING As Integer, posSHORT_DESC As
Integer, posCATALOG As Integer
'***AIM-Column Position of fields
posLONG_DESCR = 1
posMAIN_SIZE = 2
posRUN_SIZE = 3
posBRAN_SIZE = 4
posSCHEDULE = 5
posRATING = 6
posSHORT_DESC = 7
posCATALOG = 8
'***AIM-Default Settings
dblocation = "C:\WWL.PipeSpe c\book1.xls"
strPath = "C:\WWL.PipeSpe c\PipeSpec.mdb"
strPath_Securit y_WkGrp = "C:\WWL.PipeSpe c\WorkGroup\wwl _sys1.mda"
strPath_Securit y_User = ""
strPath_Securit y_Pwd = ""
strTable = 0
'***AIM-Open the Excel spreadsheet.
Set x1 = CreateObject("E xcel.applicatio n")
Set excelwbkXL = x1.Workbooks.Op en(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.Connectio n
With cnt
.Provider = "Microsoft.Jet. OLEDB.4.0"
.CursorLocation = adUseClient
'.Properties("J et OLEDB:Database Password") = "" --> password
.Properties("Je t OLEDB:System Database") =
strPath_Securit y_WkGrp
.Open strPath, strPath_Securit y_User, strPath_Securit y_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
'do nothing
ElseIf R!table_name <> "pumpa" Then
strSQL4A = "SELECT [LONG_DESCR], [MAIN_SIZE], [RUN_SIZE],
[BRAN_SIZE], [SCHEDULE], [RATING], [SHORT_DESC], [CATALOG] from " &
R!table_name
strSQL4 = strSQL4A & " ORDER BY [LONG_DESCR], [MAIN_SIZE],
[RUN_SIZE], [BRAN_SIZE], [SCHEDULE], [RATING], [SHORT_DESC], [CATALOG]
" & ";"
ElseIf R!table_name = "pumpa" Then
strSQL4A = "SELECT [LONG_DESCR], [LONG_DESCR], [CATALOG]
from " & R!table_name
strSQL4 = strSQL4A & " ORDER BY [LONG_DESCR], [CATALOG] "
& ";"
End If
strTable = strTable + 1
Set rst = New ADODB.Recordset
rst.Open strSQL4, cnt
'***AIM-Add new sheet
Set excelwksXL = excelwbkXL.Work sheets.Add
'***AIM-Spreadsheet - sheet name
excelwksXL.NAME = R!table_name
If R!table_name <> "pumpa" Then
'***AIM-Make the column headers.
For I = 1 To rst.Fields.Coun t - 1
'***AIM-Fields
If rst.Fields(I).N AME = "LONG_DESCR " Then
excelwksXL.Cell s(1, posLONG_DESCR). Value =
rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "MAIN_SIZE" Then
excelwksXL.Cell s(1, posMAIN_SIZE).V alue =
rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "RUN_SIZE" Then
excelwksXL.Cell s(1, posRUN_SIZE).Va lue =
rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "BRAN_SIZE" Then
excelwksXL.Cell s(1, posBRAN_SIZE).V alue =
rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "SCHEDULE" Then
excelwksXL.Cell s(1, posSCHEDULE).Va lue =
rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "RATING" Then
excelwksXL.Cell s(1, posRATING).Valu e =
rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "SHORT_DESC " Then
excelwksXL.Cell s(1, posSHORT_DESC). Value =
rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "CATALOG" Then
excelwksXL.Cell s(1, posCATALOG).Val ue =
rst.Fields(I).N AME
End If
Next I
'***AIM-Get data from the database and insert
'***AIM-it into the spreadsheet.
row = 2
Do While Not rst.EOF
For I = 1 To rst.Fields.Coun t - 1
'***AIM-Fields
If rst.Fields(I).N AME = "LONG_DESCR " Then
excelwksXL.Cell s(row, posLONG_DESCR) =
rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "MAIN_SIZE" Then
excelwksXL.Cell s(row, posMAIN_SIZE) =
rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "RUN_SIZE" Then
excelwksXL.Cell s(row, posRUN_SIZE) =
rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "BRAN_SIZE" Then
excelwksXL.Cell s(row, posBRAN_SIZE) =
rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "SCHEDULE" Then
excelwksXL.Cell s(row, posSCHEDULE) =
rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "RATING" Then
excelwksXL.Cell s(row, posRATING) =
rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "SHORT_DESC " Then
excelwksXL.Cell s(row, posSHORT_DESC) =
rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "CATALOG" Then
excelwksXL.Cell s(row, posCATALOG) =
rst.Fields(I).V alue
End If
Next I
row = row + 1
rst.MoveNext
Loop
ElseIf R!table_name = "pumpa" Then
'***AIM-Make the column headers.
For I = 1 To rst.Fields.Coun t - 1
'***AIM-Fields
If rst.Fields(I).N AME = "LONG_DESCR " Then
excelwksXL.Cell s(1, 2).Value = rst.Fields(I).N AME
ElseIf rst.Fields(I).N AME = "CATALOG" Then
excelwksXL.Cell s(1, 3).Value = rst.Fields(I).N AME
End If
Next I
'***AIM-Get data from the database and insert
'***AIM-it into the spreadsheet.
row = 2
Do While Not rst.EOF
For I = 1 To rst.Fields.Coun t - 1
'***AIM-Fields
If rst.Fields(I).N AME = "LONG_DESCR " Then
excelwksXL.Cell s(row, 2) = rst.Fields(I).V alue
ElseIf rst.Fields(I).N AME = "CATALOG" Then
excelwksXL.Cell s(row, 3) = rst.Fields(I).V alue
End If
Next I
row = row + 1
rst.MoveNext
Loop
End If
*************** *************** *************** *************** *******
'***AIM-Need to disable, can't handle large number of rows
(2000>)
'***AIM-Formatting
'excelwksXL.ran ge(excelwksXL.C ells(1, 1), _
'excelwksXL.Cel ls(1, row)).Select
'x1.Selection.E ntireColumn.Aut oFit
'x1.Selection.C olumns.AutoFit
'excelwksXL.ran ge(excelwksXL.C ells(1, 1), excelwksXL.Cell s(2,
row)).Select
'excelwksXL.ran ge(excelwksXL.C ells(1, 1), excelwksXL.Cell s(8,
200)).Select
'x1.Selection.E ntireColumn.Aut oFit
'***AIM-Print Setup properties
'x1.ActiveSheet .PageSetup.Zoom = 70
'x1.ActiveSheet .PageSetup.Orie ntation = xlLandscape
'x1.ActiveSheet .PageSetup.Prin tArea = "$A$1:" & "$H" & "$" &
row
'x1.ActiveSheet .PageSetup.Pape rSize = xlPaperA4
'x1.ActiveSheet .PageSetup.Sort = column1
*************** *************** *************** *******
R.MoveNext
Loop
R.Close
D.Close
excelwksXL.rang e(excelwksXL.Ce lls(1, 1), _
excelwksXL.Cell s(1, row)).Select
x1.Selection.En tireColumn.Auto Fit
Set excelwbkXL = Nothing
Set excelwksXL = Nothing
'***AIM-End Message
msgbox "Transfered over " & strTable & " tables out of 31 in
total.", vbInformation
Exit_Export_Exc el_10:
Exit Function
Err_Export_Exce l_10:
msgbox ERR.Description
Resume Exit_Export_Exc el_10
End Function
