Solved

Export from VB to Excel - Run-time error '1004': Application-defined or object-defined error

Posted on 2002-03-28
8
508 Views
Last Modified: 2007-12-19
I have the following code.  It gives me "Run-time error '1004': Application-defined or object-defined error"
Search for '****' for the line with the error.  I need to make this thing work.  I need code to help fix this.
Any help greatly appreciated.

Chess
------------------------------------------------------
Private Sub ExportData()

    On Error GoTo errHandle
   
    Dim sSql As String
    Dim rs As New ADODB.Recordset
    Dim sTradeId As String, iFundNumber As Long
    Dim intCount As Integer
    Dim sExportLogFileName As String
    Dim fileNum As Long
    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
   
    sExportLogFileName = App.Path & "\" & cmbFundNumber.Text & ".xls"
    fileNum = FreeFile
   
    If Dir(sExportLogFileName) <> "" Then
        Kill sExportLogFileName
    End If
   
    intCount = 1

    sSql = "Select RTE_TRADE_ID, FUND_NUM from ATI_RTE_TRADES WHERE FUND_NUM = " & cmbFundNumber.Text
    sSql = sSql & " AND POST_DATE is null"
    rs.Open sSql, gDBOracle, adOpenStatic
   
    ' Set header values for sheet 1.
    With xlApp.Worksheets("Sheet1").Rows(intCount) '**** Error on this line****
        .Font.Bold = True
        .Cells(1, 5).Value = "Trade Id"
        .Cells(1, 6).Value = "Fund Number"
    End With
   
    While Not rs.EOF
        sTradeId = rs.Fields("RTE_TRADE_ID")
        iFundNumber = rs.Fields("FUND_NUM")
        intCount = intCount + 1
        Call AddToSheet(intCount, sTradeId, iFundNumber)
        rs.MoveNext
    Wend
   
    xlApp.ActiveWorkbook.Worksheets(1).SaveAs sExportLogFileName
    xlApp.ActiveWorkbook.Close
 
    xlApp.Quit
 
    Set xlApp = Nothing


    Exit Sub
   
errHandle:
    MsgBox "Error " & Err.Number & " in Sub ExportData.  The error is - " & Err.Description, vbOKOnly + vbCritical, APPNAME

End Sub

Public Function AddToSheet(intCount As Integer, sTradeId As String, iFundNumber As Long)

' This function adds recordset data to sheet one row at a time.
' Values are passed from GetData procedure.
   
    With xlApp.ActiveWorkbook.Worksheets("Sheet1").Rows(intCount)
        .Cells(10, 5).Value = sTradeId
        .Cells(10, 6).Value = iFundNumber
    End With
   
End Function
0
Comment
Question by:Chess
8 Comments
 
LVL 44

Expert Comment

by:bruintje
Comment Utility
Hi Chess, does Sheet1 exist, better use Sheets(1)

:O)Bruintje
0
 
LVL 1

Author Comment

by:Chess
Comment Utility
I tried your suggestion. Did not work.  Am I doing something wrong?  Would help if you could post your code.
Chess
0
 
LVL 1

Author Comment

by:Chess
Comment Utility
FYI
I am using ADO 2.1 and Excel 97
I know that this is a known issue http://support.microsoft.com/default.aspx?scid=kb;en-us;Q246335

My hands are tied.  I am required to use ADO and Excel 97 only.
0
 
LVL 18

Expert Comment

by:bobbit31
Comment Utility
try this instead:

   With xlApp.Worksheets("Sheet1").Cells(intCount) '**** if you leave second param blank, selects whole row****
       .Font.Bold = True
       .Cells(1, 5).Value = "Trade Id"
       .Cells(1, 6).Value = "Fund Number"
   End With
   
alternatively, use ranges:

Dim xl As New Excel.Application
Dim wksht As Excel.Worksheet
Dim range As Excel.range

Set wksht = xl.Worksheets(1)
Set range = wksht.Cells(1)

With range
    .Font.Bold = True
    .Cells(1, 5).Value = "Trade Id"
    .Cells(1, 6).Value = "Fund Number"
End With
0
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 
LVL 100

Expert Comment

by:mlmcc
Comment Utility
Here's code I use to export data to a spreadsheet


Public Sub Create_Rpt_Spreadsheet(VIEW_NAME As String, _
                                   Where_Clause As String)

Dim rs_Data As ADODB.Recordset
Dim str_Select As String

Dim rs_Cols As ADODB.Recordset
Dim str_Cols As String

Dim objExcel As Excel.Application

Dim numRows As Integer
Dim numCols As Integer

Dim row As Integer
Dim col As Integer

On Error GoTo Err_SS_Recordset

    Screen.MousePointer = vbHourglass

'
'   Create recordset
'
    str_Select = "SELECT  *  FROM  " & VIEW_NAME
    If (Where_Clause <> "") Then
        str_Select = str_Select & "  WHERE  " & Where_Clause
    End If
   
    Set rs_Data = New ADODB.Recordset
    rs_Data.CursorLocation = adUseClient
    rs_Data.Open str_Select, cn, adOpenStatic, adLockReadOnly
    If (rs_Data.RecordCount <= 0) Then
        MsgBox "No data to export to Excel for your filter.", vbOKOnly, "No Data"
        rs_Data.Close
        Set rs_Data = Nothing
        Exit Sub
    End If
   
On Error GoTo Err_Create_Rpt_Spreadsheet

'
'   Initialize number of rows and columns
'
    numCols = rs_Data.Fields.count
    numRows = rs_Data.RecordCount
   
'
'   Create Excel Spreadsheet
'
    Set objExcel = New Excel.Application
    objExcel.Workbooks.Add

'
'   Set defaults for the spreadsheet
'
    objExcel.Cells.Select
    With objExcel.Selection.Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With

'
'   Open form showing export progress
'
    'frm_Export2Excel.Show
    frm_Export2Excel.lbl_Exp2Excel.Caption = "Header Row  "
   
'
'   Load column headers
'
    str_Cols = "SELECT  *  FROM  view_Excel_Col_Info where txt_ViewName = '" & VIEW_NAME & "'"
    Set rs_Cols = New ADODB.Recordset
    rs_Cols.Open str_Cols, cn, adOpenStatic, adLockReadOnly
    row = 1

'
'   Use the information from the Excel Column Information table if it exists.
'   Use the view field name otherwise
'
    If (rs_Cols.RecordCount > 0) Then
        For col = 1 To numCols
            rs_Cols.MoveFirst
            rs_Cols.Find "txt_FieldName = '" & rs_Data.Fields(col - 1).Name & "'"
            objExcel.Cells(row, col) = Trim(rs_Cols!txt_ColName)
            objExcel.Range(objExcel.Cells(row, col), objExcel.Cells(row, col)).Select
            objExcel.Selection.ColumnWidth = rs_Cols!int_ColWidth
            If (InStr(rs_Cols!txt_ColName, "Date")) Then
                objExcel.Range(objExcel.Cells(row + 1, col), objExcel.Cells(row + rs_Data.RecordCount, col)).Select
                objExcel.Selection.NumberFormat = "dd-mmm-yyyy"
            End If
        Next col
    Else
        For col = 1 To numCols
            objExcel.Cells(row, col) = Trim(rs_Data.Fields(col - 1).Name)
            objExcel.Range(objExcel.Cells(row, col), objExcel.Cells(row, col)).Select
            objExcel.Selection.ColumnWidth = 8
        Next col
    End If
    frm_Export2Excel.pb_Exp2Excel.Value = 100# * row / (numRows + 1)
'
'   Close the column information recordset
'
    rs_Cols.Close
    Set rs_Cols = Nothing

'
'   Load selected records into rows
'

    rs_Data.MoveFirst
    For row = 2 To numRows + 1
        frm_Export2Excel.lbl_Exp2Excel.Caption = "Row " & str(row - 1) & " of  " & str(numRows)
        frm_Export2Excel.pb_Exp2Excel.Value = 100# * row / (numRows + 1)
        For col = 1 To numCols
            objExcel.Cells(row, col) = rs_Data.Fields(col - 1).Value
        Next col
        objExcel.Rows(row).Select
        objExcel.Selection.RowHeight = 15
        rs_Data.MoveNext
    Next row

'
'   Activate the Excel spreadsheet
'
    Unload frm_Export2Excel
   
    objExcel.Range("A1").Select
    objExcel.Visible = True
    Screen.MousePointer = vbDefault

Exit_btnCancel_Click:
    rs_Data.Close
    Set rs_Data = Nothing
    Set objExcel = Nothing
    Exit Sub
   
Err_SS_Recordset:
    MsgBox Err.Description
    Set rs_Data = Nothing
    Screen.MousePointer = vbDefault
    Unload frm_Export2Excel
    Exit Sub

Err_Create_Rpt_Spreadsheet:
    MsgBox Err.Description
    objExcel.Visible = True
    Unload frm_Export2Excel
    Resume Exit_btnCancel_Click

End Sub

mlmcc
0
 
LVL 44

Accepted Solution

by:
bruintje earned 150 total points
Comment Utility
or add the workbook

   xlApp.Workbooks.Add
   With xlApp.Workbooks(1).Worksheets(1)   '**** Error on this line****
       With .Cells(1, 5)
         .Value = "Trade Id"
         .Font.Bold = True
       End With
       With .Cells(1, 6)
         .Value = "Fund Number"
         .Font.Bold = True
       End With
   End With
0
 
LVL 1

Author Comment

by:Chess
Comment Utility
bruintje,
Thanks!  It was like looking for a needle in a haystack.
Many thanks to all others for their contribution.
Chess
0
 
LVL 44

Expert Comment

by:bruintje
Comment Utility
didn't have the possibillity to test until i came home ;)
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now