vba - excel vba代码几次运行后始终损坏我的文件

Question

我的子集相对较长，每天都会在我的excel文件列表中运行几次。经过几次运行后，文件便损坏了，通常这不会成为问题，因为它实际上并不会影响任何数据。但是，我有另一个程序可以打开每个excel并从每个excel中提取一些关键数据以制作摘要表。因为损坏的文件给出了一条消息，指出“某些内容存在问题”，所以摘要程序会以

run-time error '1004': Method of object 'Workbooks' Failed

我一生无法弄清楚代码中是什么导致了损坏。有没有一种方法可以使摘要代码忽略损坏通知？香港专业教育学院尝试了许多不同的事情，包括关闭我的代码中的应用程序通知无济于事。

任何帮助是极大的赞赏!请把我的所有代码张贴在下面，并作简要说明:

Here is the code from the summary file that opens each of the individual files and pulls data:

Sub OEEsummmary()
Dim ActCycCell, ExpCycCell, ExpCurCycCell, ShiftCell, DifCell, DownCell, DTResACell, DTResBCell, PartCell, OpNamCell, OprCell, RejCell, RejResCell As Range
Dim MySheet As Worksheet
Dim Txt$, MyPath$, MyWB$
Dim myValue As Integer
Dim x As Long
Dim v As Variant, r As Range, rWhere As Range
MyPath = "L:\Manufacturing Engineering\Samuel Hatcher\"
x = 2
Set MySheet = ActiveSheet

'Application.ScreenUpdating = False
Application.EnableEvents = False

MySheet.Range("B2:G18").ClearContents
MySheet.Range("J2:O18").ClearContents

Do While MySheet.Range("A" & x).Value <> ""
    MyWB = MySheet.Range("A" & x).Text
    Workbooks.Open Filename:=MyPath & MyWB, ReadOnly:=True, IgnoreReadOnlyRecommended:=True

    Set ActCycCell = ActiveSheet.Range("E21")
    Set ExpCycCell = ActiveSheet.Range("D21")
    Set ShiftCell = ActiveSheet.Range("E2")
    Set DownCell = ActiveSheet.Range("K28")
    Set DTResACell = ActiveWorkbook.Worksheets("Downtime").Range("O9")
    Set DTResBCell = ActiveWorkbook.Worksheets("Downtime").Range("O10")
    Set PartCell = ActiveSheet.Range("E4")
    Set ExpCurCycCell = ActiveSheet.Range("D22")
    If ActiveSheet.Range("I3") = "" Then
        Set OpNamCell = ActiveSheet.Range("I2")
        Else
        Set OpNamCell = ActiveSheet.Range("I3")
    End If
    Set OprCell = ActiveSheet.Range("C4")
    Set RejCell = ActiveSheet.Range("H21")
    Set RejResCell = ActiveWorkbook.Worksheets("Rejected Parts").Range("H5")
        With MySheet.Range("A" & x)
            .Offset(0, 14).Value = OprCell.Value
            .Offset(0, 13).Value = OpNamCell.Value
            .Offset(0, 12).Value = PartCell.Value
            .Offset(0, 11).Value = ShiftCell.Value
            .Offset(0, 10).Value = RejResCell.Value
            .Offset(0, 9).Value = RejCell.Value
            .Offset(0, 6).Value = ActCycCell.Value
            .Offset(0, 5).Value = ExpCycCell.Value
            .Offset(0, 4).Value = ExpCurCycCell.Value
            .Offset(0, 3).Value = DTResBCell.Value
            .Offset(0, 2).Value = DTResACell.Value
            .Offset(0, 1).Value = DownCell.Value
        End With
    ActiveWorkbook.Close savechanges:=False
    x = x + 1
Loop

Call sort
'Application.ScreenUpdating = True
Application.EnableEvents = True


End Sub

Clears the page of data to prepare it for a new shift of entering data:

Sub ClearFrontEnd()


Sheets("Front End").Unprotect ("29745")
'prompts user to confirm if they realy want to clear entry
response = MsgBox("Are You Sure?", vbYesNo)

If response = vbNo Then
    Exit Sub
End If

'checks to see if operator number is there
If range("I3").Value = "" Then
    MsgBox "ENTER OPORATOR # AND CLICK NEW SHIFT AGAIN"

Else

    Call StopTimer
    Call prodChoose
    Call transfer

    Application.ScreenUpdating = False
    ActiveWorkbook.Save

Sheets("Front End").Unprotect ("29745")
    Sheets("Front End").Select
'Deletes the data from the entry and unique key fields
    range("E8:E20").ClearContents
    range("I8:I27").ClearContents
    range("J8:J27").ClearContents
    range("K8:K27").ClearContents
    range("I3").ClearContents
    range("H8").Value = ""
    range("H9").Value = ""
    range("H10").Value = ""
    range("H11").Value = ""
    range("H12").Value = ""
    range("H13").Value = ""
    range("H14").Value = ""
    range("H15").Value = ""
    range("H16").Value = ""
    range("H17").Value = ""
    range("H18").Value = ""
    range("H19").Value = ""
    range("H20").Value = ""

    range("A1").Select

    MsgBox "Please enter the correct values for SHIFT #, SHIFT LENGTH, PART #, AND OPORATOR #, Thanks! Have a great day!!"

End If

Sheets("Front End").Protect ("29745")
Call timerchoose
Application.ScreenUpdating = True

End Sub

This copies the data from the front page to a raw data sheet every hour:

Sub transfer()

Sheets("Front End").Unprotect ("29745")

Application.ScreenUpdating = False

    Dim x As Long
    Dim v As Variant, r As range, rWhere As range

'set starting point at row 8
    x = 8
'defines the sheet the data is being coppied from and pasted to
    Dim sourceSheet As Worksheet: Set sourceSheet = ThisWorkbook.Worksheets("Front End")
    Dim destSheet As Worksheet: Set destSheet = ThisWorkbook.Worksheets("Raw Data")

If sourceSheet.range("I3").Value = "" Then

    Call StartTimer
    Exit Sub


Else

    Do While range("L" & x).Value <> ""
'Checks if the unique code is in the raw data sheet or not
        v = sourceSheet.range("M" & x).Value
        Set rWhere = destSheet.range("S:S")
        Set r = rWhere.Find(what:=v, After:=rWhere(1))
        If r Is Nothing Then

'selects the next row where the 1st column is empty
            lMaxRows = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
'pastes the data from the specified cells into the next empty row
            destSheet.range("A" & lMaxRows + 1).Value = sourceSheet.range("C2").Value
            destSheet.range("M" & lMaxRows + 1).Value = sourceSheet.range("E2").Value
            destSheet.range("N" & lMaxRows + 1).Value = sourceSheet.range("E4").Value
            destSheet.range("P" & lMaxRows + 1).Value = sourceSheet.range("G4").Value
            destSheet.range("Q" & lMaxRows + 1).Value = sourceSheet.range("C4").Value
            destSheet.range("O" & lMaxRows + 1).Value = sourceSheet.range("I3").Value
            destSheet.range("B" & lMaxRows + 1).Value = sourceSheet.range("J" & x).Value
            destSheet.range("C" & lMaxRows + 1).Value = sourceSheet.range("K" & x).Value
            destSheet.range("D" & lMaxRows + 1).Value = sourceSheet.range("L" & x).Value
            destSheet.range("E" & lMaxRows + 1).Value = sourceSheet.range("I" & x).Value
            destSheet.range("S" & lMaxRows + 1).Value = sourceSheet.range("M" & x).Value

            x = x + 1
        Else
            x = x + 1
        End If
    Loop

    x = 8

    Do While range("D" & x).Value <> 0
    If range("E" & x).Value <> "" Then
'Checks if the unique code is in the raw data sheet or not
        v = sourceSheet.range("A" & x).Value
        Set rWhere = destSheet.range("S:S")
        Set r = rWhere.Find(what:=v, After:=rWhere(1))
        If r Is Nothing Then

'selects the next row where the 1st column is empty
            lMaxRows = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
'pastes the data from the specified cells into the next empty row
            destSheet.range("A" & lMaxRows + 1).Value = sourceSheet.range("C2").Value
            destSheet.range("M" & lMaxRows + 1).Value = sourceSheet.range("E2").Value
            destSheet.range("N" & lMaxRows + 1).Value = sourceSheet.range("E4").Value
            destSheet.range("P" & lMaxRows + 1).Value = sourceSheet.range("G4").Value
            destSheet.range("Q" & lMaxRows + 1).Value = sourceSheet.range("C4").Value
            destSheet.range("O" & lMaxRows + 1).Value = sourceSheet.range("I3").Value
            destSheet.range("B" & lMaxRows + 1).Value = sourceSheet.range("B" & x).Value
            destSheet.range("L" & lMaxRows + 1).Value = sourceSheet.range("C" & x).Value
            destSheet.range("F" & lMaxRows + 1).Value = sourceSheet.range("D" & x).Value
            destSheet.range("G" & lMaxRows + 1).Value = sourceSheet.range("E" & x).Value
            destSheet.range("I" & lMaxRows + 1).Value = sourceSheet.range("G" & x).Value
            destSheet.range("K" & lMaxRows + 1).Value = sourceSheet.range("H" & x).Value
            destSheet.range("H" & lMaxRows + 1).Value = sourceSheet.range("N" & x).Value
            destSheet.range("J" & lMaxRows + 1).Value = sourceSheet.range("O" & x).Value
            destSheet.range("S" & lMaxRows + 1).Value = sourceSheet.range("A" & x).Value

            x = x + 1
        Else
            x = x + 1
        End If
    Else
        x = x + 1
    End If
    Loop
'sorts Raw Data table after new data is added
    Dim ws  As Worksheet
    Set ws = ActiveWorkbook.Worksheets("Raw Data")
'specifies how to sort the data
    With ws.Sort.SortFields
        .Clear
        .add Key:=ws.range("A2:A" & lMaxRows + 1), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .add Key:=ws.range("B2:B" & lMaxRows + 1), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
'specifies range over which to sort
    End With
    With ws.Sort
        .SetRange ws.range("A1:S" & lMaxRows + 1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With



End If


Sheets("Front End").Protect ("29745")


    Call SortDTWeek
    Call SortDTMonth
    Call StartTimer


Application.ScreenUpdating = True

End Sub

This checks a few cells constantly to see if they have been double clicked, if so it puts the current time in that cell

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As range, cancel As Boolean)
'Adds downtime start and finish values
'Check to see if the click/selected cell is in columns I or J
    If Not Intersect(Target, range("J:K")) Is Nothing Then

'Make sure cell is in range
        If Target.Row > 7 And Target.Row <= 27 Then

'Update the value
            Target.Value = Time()
        End If

    End If

End Sub

Checks to see if a set of cells has been changed, if so it puts the now() value in a corresponding "key" column

Private Sub Worksheet_Change(ByVal Target As range)
Sheets("Front End").Unprotect ("29745")
Dim cell As range

'Adds unique keyA values
'Check to see if the changed cell is in column E
    If Not Intersect(Target, range("E:E")) Is Nothing Then
        For Each cell In Target.Cells
            If cell.Value <> vbNullString And Target.Row > 7 And Target.Row <= 20 Then
            'Update the "KeyA" value
                Sheets("Front End").range("A" & Target.Row).Value = Now()
            End If
        Next cell
    Else

'Adds unique keyB values
'Check to see if the changed cell is in column K
    If Not Intersect(Target, range("K:K")) Is Nothing Then
        For Each cell In Target.Cells
            If cell.Value <> vbNullString And (Target.Row > "6" And Target.Row <= "27") Then
            'Update the "KeyM" value
                range("M" & Target.Row).Value = Now()
            End If
        Next cell
    End If
End If
Sheets("Front End").Unprotect ("29745")
End Sub

感谢您的任何输入，这个问题一直让我发疯

Answer 1

正如@MLind在评论中建议的那样，绕过损坏的文件错误并提取一些数据，我将此添加到了我的代码中:

Workbooks.Open Filename:=MyPath & MyWB, ReadOnly:=True, IgnoreReadOnlyRecommended:=True, 
    CorruptLoad:=xlExtractData

并使用

Application.DisplayAlerts = False

在循环中，以防止任何 pop 框停止子