这是我的第一篇文章，所以如果我做错了，请不要把我钉在十字架上。 我已经编写了这段代码，该代码可以打开一系列工作簿（打开的工作簿的数量取决于该国家/地区的诊所数量（最多200个）），然后从该工作簿中复制任何问题数据进入宏工作簿。然后，它将处理所有已跟踪的问题，并将它们复制到另一个工作簿中，并将其保存为问题日志。在运行过程中，在某个随机点上，我遇到了一个完全使excel崩溃的自动化错误。我不会在错误线上中断。我没有任何交互或其他警告，并且“自动化错误”没有错误代码，只是带有“确定”和“帮助”按钮的自动化错误。帮助按钮对我没有任何帮助。我尝试设置计时器以打开工作簿。我尝试禁用打开工作簿时可能运行的宏，以加快它们的速度。我已经尝试过逐步执行，但不会产生错误，因此仅当它以全倾斜运行时。 我已经读到这些错误是由于VBA无法引用工作簿对象引起的，因为在与该工作簿关联的对象被调用时它尚未完全“打开”，因此计时和宏终止代码被加入，但无济于事。 有人可以告诉我我做错了什么吗？这是工作，我需要此报告才能正常运行。感谢任何愿意提前帮助的人。 以下是从工作簿中提取问题的代码：Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
Sub GetIssues()
Dim country As String, checkPer As String, CheckMon As String, fiscYear As String, fPath As String, openFile As String, openName As String, clerk As String
Dim company As Integer, i As Integer, clinic As Integer, checkMonDays As Integer, last As Integer, b As Integer, tableRow As Integer
Dim setupWS As Worksheet, checkWS As Worksheet, issueWS As Worksheet, valueWS As Worksheet, metaWS As Worksheet, ws As Worksheet
Dim checkWB As Workbook
Dim fso As New FileSystemObject
Dim listObj As ListObject
Dim issueWSfile As Range, valueWSfile As Range, checkWSRng As Range, checkWSRng2 As Range, dateRange As Range, cell As Range, tableRng As Range, tableRng2 As Range
Dim startDate As Date, Timer As Date, StartTime As Date, EndTime As Date
Dim NowTick As Long, EndTick As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
'previousSecurity = Application.AutomationSecurity
'Application.AutomationSecurity = msoAutomationSecurityForceDisable
StartTime = TimeValue(Time)
Set setupWS = ThisWorkbook.Sheets("Setup")
Set metaWS = ThisWorkbook.Sheets("Meta Data")
Set issueWS = ThisWorkbook.Sheets("Issues")
Set valueWS = ThisWorkbook.Sheets("Values")
Set dateRange = issueWS.Range("F1:AL1")
last = metaWS.Cells(Rows.count, "B").End(xlUp).Row
startDate = DateValue(setupWS.Range("F4").Value)
Set issueWSfile = issueWS.Range("A2:A" & last)
Set valueWSfile = valueWS.Range("A2:A" & last)
issueWS.Range("A2:AK1000,F1:AJ1").ClearContents
valueWS.Range("A2:AK1000,F1:AJ1").ClearContents
dateRange.ClearContents
fPath = Left(ThisWorkbook.Path, Len(ThisWorkbook.Path) - Len("Takings Control Recs"))
checkPer = Trim(Right(GetIssForm.ComboBox2.Value, 3))
fiscYear = Left(GetIssForm.ComboBox2.Value, 4)
If checkPer = "P1" Then
CheckMon = "Oct"
ElseIf checkPer = "P2" Then
CheckMon = "Nov"
ElseIf checkPer = "P3" Then
CheckMon = "Dec"
ElseIf checkPer = "P4" Then
CheckMon = "Jan"
ElseIf checkPer = "P5" Then
CheckMon = "Feb"
ElseIf checkPer = "P6" Then
CheckMon = "Mar"
ElseIf checkPer = "P7" Then
CheckMon = "Apr"
ElseIf checkPer = "P8" Then
CheckMon = "May"
ElseIf checkPer = "P9" Then
CheckMon = "Jun"
ElseIf checkPer = "P10" Then
CheckMon = "Jul"
ElseIf checkPer = "P11" Then
CheckMon = "Aug"
ElseIf checkPer = "P12" Then
CheckMon = "Sep"
End If
Application.Calculation = xlCalculationAutomatic
setupWS.Range("F1").Value = checkPer
Application.Calculation = xlCalculationManual
If CheckMon = "Jan" Or CheckMon = "Mar" Or CheckMon = "May" Or CheckMon = "Jul" Or CheckMon = "Aug" Or CheckMon = "Oct" Or CheckMon = "Dec" Then
checkMonDays = 31
ElseIf CheckMon = "Apr" Or CheckMon = "Jun" Or CheckMon = "Sep" Or CheckMon = "Nov" Then
checkMonDays = 30
Else: checkMonDays = 28
End If
For b = 1 To checkMonDays
issueWS.Cells(1, b + 5).Value = startDate
valueWS.Cells(1, b + 5).Value = startDate
startDate = startDate + 1
Next b
country = GetIssForm.ComboBox3.Value
'Unload GetIssForm
For i = 5 To last
If metaWS.Range("H" & i).Value = country Then
company = metaWS.Range("D" & i).Value
clinic = metaWS.Range("B" & i).Value
clerk = metaWS.Range("F" & i).Value
openFile = fPath & country & "\" & fiscYear & "\" & checkPer & "\E " & company & "\" & clinic & " " & checkPer & " " & CheckMon & ".xlsb"
If Dir(openFile) <> "" Then
openName = fso.getfilename(openFile)
Set checkWB = Workbooks.Open(openFile)
'EndTick = GetTickCount + 500
'Do
' NowTick = GetTickCount
' DoEvents
'Loop Until NowTick > EndTick
Set checkWS = checkWB.Sheets("Transaction Hub")
Set checkWSRng = checkWS.Range("AX11:AX41")
Set checkWSRng2 = checkWS.Range("AU11:AU41")
issueWS.Range("A" & i - 3).Value = openFile
issueWS.Range("B" & i - 3).Value = company
issueWS.Range("C" & i - 3).Value = clinic
issueWS.Range("D" & i - 3).Value = clerk
issueWS.Range("E" & i - 3).Value = country
valueWS.Range("A" & i - 3).Value = openFile
valueWS.Range("B" & i - 3).Value = company
valueWS.Range("C" & i - 3).Value = clinic
valueWS.Range("D" & i - 3).Value = clerk
valueWS.Range("E" & i - 3).Value = country
checkWSRng.Copy
issueWS.Range("F" & i - 3).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, , True
checkWSRng2.Copy
valueWS.Range("F" & i - 3).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, , True
Application.CutCopyMode = False
Workbooks(openName).Close False
Set checkWB = Nothing
Else: End If
End If
Next i
last = issueWS.Cells(Rows.count, "A").End(xlUp).Row
Set listObj = issueWS.ListObjects(1)
listObj.Resize Range("A1:AJ" & last)
Set listObj = valueWS.ListObjects(1)
listObj.Resize Range("A1:AJ" & last)
Set tableRng = issueWS.ListObjects("Table2").Range
Set tableRng2 = valueWS.ListObjects("Table1").Range
issueWS.Activate
For tableRow = tableRng.Row + tableRng.Rows.count - 1 To tableRng.Row Step -1
If Application.WorksheetFunction.CountA(Rows(tableRow)) = 0 Then Rows(tableRow).EntireRow.Delete
Next
valueWS.Activate
For tableRow = tableRng2.Row + tableRng2.Rows.count - 1 To tableRng2.Row Step -1
If Application.WorksheetFunction.CountA(Rows(tableRow)) = 0 Then Rows(tableRow).EntireRow.Delete
Next
For Each ws In ThisWorkbook.Worksheets
ws.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Range("A1").Select
Next ws
ThisWorkbook.Sheets("Run").Activate
issueWS.Range("B:D").EntireColumn.AutoFit
valueWS.Range("B:D").EntireColumn.AutoFit
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
'Application.AutomationSecurity = previousSecurity
EndTime = TimeValue(Time)
Timer = Format(EndTime - StartTime, "hh:mm:ss")
'MsgBox "Finished in " & -Timer & " seconds", vbOKOnly, "Workbooks Created -"
Call ReportIssues
End Sub```
And here's the code that creates the issue log:
```Option Explicit
Sub ReportIssues()
Dim ARow As Long, issuesLastRow As Long, ACol As Long, issuesLastCol As Long, IRow As Long, issuesLastRow2 As Long, issuesLastCol2 As Long
Dim DateNum As String, Month As String, Year As String, country As String, TestStr As String, answer As String, fPath As String
Dim issuesWB As Workbook
Dim ws As Worksheet, issuesWS As Worksheet, valuesWS As Worksheet, dataWS As Worksheet, setupWS As Worksheet
Dim count As Integer
Application.EnableEvents = False
Application.DisplayAlerts = False
Set dataWS = ThisWorkbook.Sheets("Issues")
Set setupWS = ThisWorkbook.Sheets("Setup")
Set valuesWS = ThisWorkbook.Sheets("Values")
dataWS.Activate
fPath = ThisWorkbook.Path & "\Issue Logs\"
Debug.Print fPath
issuesLastRow = dataWS.Cells(Rows.count, "B").End(xlUp).Row
issuesLastCol = dataWS.Cells(1, Columns.count).End(xlToLeft).Column
issuesLastRow2 = valuesWS.Cells(Rows.count, "B").End(xlUp).Row
issuesLastCol2 = valuesWS.Cells(1, Columns.count).End(xlToLeft).Column
IRow = 3
DateNum = Replace(setupWS.Range("D2"), "/", "")
count = 0
Application.ScreenUpdating = False
country = GetIssForm.ComboBox3.Value
Unload GetIssForm
Set issuesWB = Workbooks.Open("Z:\Finance\HO European Transformation\15.SSC\Q Track\Build\Issues Sheet Temp.xlsb")
Set issuesWS = issuesWB.Sheets("Issues")
dataWS.ListObjects("Table2").Range.AutoFilter Field:=5, Criteria1:=country
valuesWS.ListObjects("Table1").Range.AutoFilter Field:=5, Criteria1:=country
If Dir(fPath & country & " " & DateNum & ".xlsb") = "" Then
here:
For ACol = 6 To issuesLastCol
For ARow = 2 To issuesLastRow
If Not IsError(dataWS.Cells(ARow, ACol)) And dataWS.Cells(ARow, ACol) <> 0 And dataWS.Cells(ARow, ACol) <> "" And Len(dataWS.Cells(ARow, ACol)) > 5 And dataWS.Cells(ARow, 5) = country Then 'And dataWS.Cells(1, ACol) < setupWS.Range("D2") Then 'And dataWS.Cells(1, ACol) > setupWS.Range("F4") - 1 Then
issuesWS.Cells(IRow, 1) = dataWS.Cells(1, ACol)
issuesWS.Cells(IRow, 2) = dataWS.Cells(ARow, 5)
issuesWS.Cells(IRow, 3) = dataWS.Cells(ARow, 3)
issuesWS.Cells(IRow, 4) = dataWS.Cells(ARow, 2)
issuesWS.Cells(IRow, 5) = dataWS.Cells(ARow, ACol)
issuesWS.Cells(IRow, 6) = valuesWS.Cells(ARow, ACol)
IRow = IRow + 1
count = count + 1
End If
Next ARow
ARow = 2
Next ACol
If count = 0 Then
For ACol = 6 To issuesLastCol2
For ARow = 2 To issuesLastRow2
If Not IsError(valuesWS.Cells(ARow, ACol)) And valuesWS.Cells(ARow, ACol) <> 0 And valuesWS.Cells(ARow, ACol) <> "" And valuesWS.Cells(ARow, 5) = country Then 'And dataWS.Cells(1, ACol) < setupWS.Range("D2") Then 'And dataWS.Cells(1, ACol) > setupWS.Range("F4") - 1 Then
issuesWS.Cells(IRow, 1) = dataWS.Cells(1, ACol)
issuesWS.Cells(IRow, 2) = dataWS.Cells(ARow, 5)
issuesWS.Cells(IRow, 3) = dataWS.Cells(ARow, 3)
issuesWS.Cells(IRow, 4) = dataWS.Cells(ARow, 2)
issuesWS.Cells(IRow, 5) = dataWS.Cells(ARow, ACol)
issuesWS.Cells(IRow, 6) = valuesWS.Cells(ARow, ACol)
IRow = IRow + 1
count = count + 1
End If
Next ARow
ARow = 2
Next ACol
End If
With issuesWB
.SaveAs fPath & country & " " & DateNum & ".xlsb"
.Activate
.Close False
End With
MsgBox country & " Issue Sheet saved to Issue Log folder.", vbOKOnly, "File Saved -"
ElseIf Dir(fPath & country & " " & DateNum & ".xlsb") <> "" Then
answer = MsgBox("Do you wish to overwrite the previous Issue Report file for " & country & "?", vbYesNo, "Existing File -")
If answer = vbYes Then
GoTo here:
ElseIf answer = vbNo Then
issuesWB.Close False
End If
End If
For Each ws In ThisWorkbook.Worksheets
ws.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Range("A1").Select
Next ws
ThisWorkbook.Sheets("Run").Activate
'Unload RepIssForm
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub```
0 个答案:
没有答案