Я программировал этот код для отправки значений из запроса Access в электронную таблицу Excel. Существует ошибка, возникающая при каждом запуске макроса. Появляется: «Run = time error 1004: ошибка приложения или объекта», странная вещь в том, что она появляется случайным образом в разных местах кода, и после нажатия «Debug» я снова нажимаю 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