excel vba 运行几次后代码不断损坏我的文件
excel vba code corrupting my file consistently after a few runs
我有一组相对较长的子程序，它们每天在我的 excel 文件列表中出现几次 运行。几 运行 秒后，文件就会损坏，这通常不会成为问题 b/c 它不会真正影响任何数据。然而，我有另一个程序可以打开每个 excel 并从每个 excel 中提取一些关键数据来进行总结 sheet。因为损坏的文件给出了一条消息，上面写着 "there is a problem with some of your content" 摘要程序以
停止
run-time error '1004': Method of object 'Workbooks' Failed
我这辈子都弄不明白我的代码中是什么导致了损坏。有没有办法让摘要代码忽略损坏通知？我尝试了一些不同的方法，包括在我的代码中关闭应用程序通知，但都无济于事。
非常感谢任何帮助！ ill post 我所有的代码，下面有一个简短的描述：
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
感谢您的意见，这个问题一直让我抓狂
正如@MLind 在评论中建议的那样，为了绕过损坏的文件错误并提取一些数据，我将其添加到我的代码中：
Workbooks.Open Filename:=MyPath & MyWB, ReadOnly:=True, IgnoreReadOnlyRecommended:=True,
CorruptLoad:=xlExtractData
并使用
Application.DisplayAlerts = False
在循环内防止任何弹出框停止子
我有一组相对较长的子程序，它们每天在我的 excel 文件列表中出现几次 运行。几 运行 秒后，文件就会损坏，这通常不会成为问题 b/c 它不会真正影响任何数据。然而，我有另一个程序可以打开每个 excel 并从每个 excel 中提取一些关键数据来进行总结 sheet。因为损坏的文件给出了一条消息，上面写着 "there is a problem with some of your content" 摘要程序以
停止run-time error '1004': Method of object 'Workbooks' Failed
我这辈子都弄不明白我的代码中是什么导致了损坏。有没有办法让摘要代码忽略损坏通知？我尝试了一些不同的方法，包括在我的代码中关闭应用程序通知，但都无济于事。
非常感谢任何帮助！ ill post 我所有的代码，下面有一个简短的描述：
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
感谢您的意见，这个问题一直让我抓狂
正如@MLind 在评论中建议的那样，为了绕过损坏的文件错误并提取一些数据，我将其添加到我的代码中：
Workbooks.Open Filename:=MyPath & MyWB, ReadOnly:=True, IgnoreReadOnlyRecommended:=True,
CorruptLoad:=xlExtractData
并使用
Application.DisplayAlerts = False
在循环内防止任何弹出框停止子