运行时错误1004应用程序定义的错误或对象定义的错误

时间:2019-07-09 07:44:01

标签: excel vba ms-access access-vba

我一直在对该代码进行编程,以将Access查询中的值发送到Excel电子表格。每当我运行宏时,都会发生一个错误。出现:“运行=时间错误1004:应用程序定义的错误或对象定义的错误”,它的怪异之处是它随机出现在代码的不同位置,单击“调试”后,我再次按F5而不进行修改任何东西,代码再次运行平稳,好像什么也没发生。

奇怪的是,它按预期方式工作,可以正常工作,可能再次出现该错误几次,但是除了停止该宏之外,什么也没有发生,并且结果令人满意。

奇怪的是,当我在循环中包含msgbox时,该错误没有发生。

'Declare ACCESS objects&variables 
Public dbsContract As DAO.Database
Public rstWeightDONE As DAO.Recordset
Public rstWeightTODO As DAO.Recordset
'Declare EXCEL objects&variables
Public objExcelApp As Object
Public wb As Object
Public ws As Object 
'Declare Macro variables
Public InitialRow As Integer
Public varRow As Integer 'row variable for excel
Public LastRow As Integer 'Variable to save the highest row value to use later at SUB CellFormulaFormating

Sub DataVisual()
    '---------------------------------------------------------------------------------------
    'Title: Data Visualization v3
    'Description: The purpose of this macro is to transfer the weight Done and To-Do from queries [sum Weight(Done)/Field/IWP]&[sum Weight(Done)/Field/IWP] to
    '             the contract progress control excel table to visualize the contract progress data.
    '---------------------------------------------------------------------------------------
    'Declare EXCEL objects&variables
    Dim varColumn As Integer 'column variable for excel
    'Declare Macro variables
    Dim CountOut As Integer
    Dim varContract As String

    'Set ACCESS variables
    Set dbsContract = CurrentDb
    Set rstWeightDONE = dbsContract.OpenRecordset("sum Weight(Done)/Field/IWP")
    Set rstWeightTODO = dbsContract.OpenRecordset("sum Weight(To-Do)/Field/IWP")

    'Here is introduced by the user the contract code that wants to visualize. In order the macro works, it is mandatory the Contract excel file's name has the same name as the contract code introduced
    'https://www.excel-easy.com/vba/examples/inputbox-function.html
    varContract = InputBox("Introduce the Contract Code you want to Visualize, based on Contract Codes seen at 'Contract List' table from this Database e.g. A0:")

    'Set EXCEL variables
    Set objExcelApp = CreateObject("Excel.Application")
    Set wb = objExcelApp.Workbooks.Open(Application.CurrentProject.Path & "\" & varContract & ".xlsx")  'Declare Path where to find the Excel file. It is mandatory it is placed at the same directory as the ACCESS database.
    Set ws = wb.Sheets(1)  'Page number 1 of the excel workbook
    varColumn = 3

    rstWeightDONE.MoveFirst
    rstWeightTODO.MoveFirst
    CountOut = 0
    InitialRow = 6 '58

    'Find Initial Row '-------------------------- MOD 03/07 [ FUNCIONA
    Do
        If IsEmpty(ws.Cells(InitialRow, 3)) = True Then
            CountOut = CountOut + 1
        Else
            CountOut = 0
        End If
        If CountOut = 3 Then
            InitialRow = InitialRow - 2
            Exit Do
        End If
        InitialRow = InitialRow + 1
    Loop Until Mid(ws.Cells(InitialRow + 1, 4), 1, 3) = "CWP" ']

    MsgBox InitialRow & " " & Mid(ws.Cells(InitialRow, 4), 1, 3)

    CountOut = 0
    varRow = InitialRow '@1
    HighestRow = 0
    Do
        If ws.Cells(varRow, varColumn) = "" Then '@2 Checks there is no value inside the cell
            CountOut = CountOut + 1
            If CountOut = 2 Then 'check there aren't two consecutive blank rows
                CountOut = 0
                '@6: Creates Missing CWP/IWP in the Excel table
                ws.rows(3).copy 'Set-Up Row: Copy Excel CWP row layout
                ws.Paste Destination:=ws.rows(varRow)  'Paste it at the required row
                ws.Cells(varRow, varColumn) = rstWeightTODO![IOCONST-WBS]       'introduce in excel the CWP Code To-Do value
                ws.Cells(varRow, varColumn + 1) = rstWeightTODO![Designation]     'introduce in excel the CWP Description To-Do value
                ws.Cells(varRow, varColumn + 3) = "=SUM(F" & varRow + 1 & ")" 'introduce in excel the CWP weight TODO formula
                ws.Cells(varRow, varColumn + 4) = "=SUM(G" & varRow + 1 & ")" 'introduce in excel the CWP weight DONE formula
                ws.Cells(varRow, varColumn - 1) = rstWeightTODO![IOCONST-WBS]     'introduce in excel the CWP Code To-Do value
                varRow = varRow + 1

                ws.rows(4).copy 'Set-Up Row: Copy Excel IWP row layout
                ws.Paste Destination:=ws.rows(varRow) 'Paste it at the required row
                ws.Cells(varRow, varColumn) = rstWeightTODO![IWP-Code]       'introduce in excel the IWP Code To-Do value
                ws.Cells(varRow, varColumn + 1) = rstWeightTODO![ActivityDesignation]     'introduce in excel the IWP Description To-Do value
                ws.Cells(varRow, varColumn - 1) = rstWeightTODO![IOCONST-WBS]     'introduce in excel the CWP Code To-Do value

                varRow = varRow + 1
                ws.rows(5).copy 'Set-Up Row: Copy Excel Field row layout
                ws.Paste Destination:=ws.rows(varRow)  'Paste it at the required row
                '11@
                'MsgBox ("Excel Row: " & varRow & " " & "Record (%): " & rstWeightTODO.PercentPosition)
                ws.Cells(varRow, varColumn) = rstWeightTODO![IWP-Code]       'introduce in excel the IWP Code To-Do value
                ws.Cells(varRow, varColumn + 1) = rstWeightTODO![Field]     'introduce in excel the IWP Description To-Do value
                ws.Cells(varRow, varColumn + 3) = rstWeightTODO![Weight (To-Do)]     'introduce in excel the IWP Description To-Do value
                ws.Cells(varRow, varColumn - 1) = rstWeightTODO![IOCONST-WBS]     'introduce in excel the CWP Code To-Do value
                ws.rows(6).copy 'Set-Up Row: Copy Excel Grayline row layout as separator
                ws.Paste Destination:=ws.rows(varRow + 1) 'Paste it at the required row

                Call DataEntryDONE(varRow, varColumn) 'Call function

            Else
                varRow = varRow + 1
            End If
        Else 'in case there is a value in the checked cell...
            CountOut = 0
            If ws.Cells(varRow, varColumn) = rstWeightTODO![IWP-Code] And ws.Cells(varRow, varColumn + 1) = rstWeightTODO![Field] Then '@7 Checks if match the cell value with the on-going Access record in review
                ws.Cells(varRow, varColumn + 3) = rstWeightTODO![Weight (To-Do)] '@10
                Call DataEntryDONE(varRow, varColumn)  'Call function
            Else
                If ws.Cells(varRow, varColumn) = rstWeightTODO![IWP-Code] And ws.Cells(varRow + 1, varColumn) <> rstWeightTODO![IWP-Code] Then '@8 If the value don't match at @7 then check if there are no more fields by this specific IWP in the Excel
                    ws.rows(varRow).entirerow.insert '@9 if it's the last designation in the excel, and it did not appear, include it.
                    '11@
                    ws.rows(5).copy 'Set-Up Row: Copy Excel Field row layout
                    ws.Paste Destination:=ws.rows(varRow) 'Paste it at the required row
                    ws.Cells(varRow, varColumn) = rstWeightTODO![IWP-Code]       'introduce in excel the IWP Code To-Do value
                    ws.Cells(varRow, varColumn + 1) = rstWeightTODO![Field]     'introduce in excel the IWP Description To-Do value
                    ws.Cells(varRow, varColumn + 3) = rstWeightTODO![Weight (To-Do)]     'introduce in excel the IWP Description To-Do value
                    ws.Cells(varRow, varColumn - 1) = rstWeightTODO![IOCONST-WBS]     'introduce in excel the CWP Code To-Do value
                    Call DataEntryDONE(varRow, varColumn) 'Call function
                Else
                    varRow = varRow + 1 '@5
                End If
            End If
        End If

    Loop Until rstWeightTODO.EOF 'Infinite Loop 'rstWeightTODO.AbsolutePosition > 20

    Call CellFormulaFormating(varRow, varColumn)
    ws.rows(6).copy 'Set-Up Row: Copy Excel Grayline row layout as separator
    ws.Paste Destination:=ws.rows(InitialRow - 1) 'Paste it at the required row

    wb.Close SaveChanges:=True
    Set wb = Nothing
    Set objExcelApp = Nothing
    MsgBox "The macro has finished."
    Exit Sub
End Sub

0 个答案:

没有答案