Есть такая проблема, при выполнении некоторых макросов по окончанию выдается ошибка Device I/O Error с кнопками ok/help. Обычно после того как эксель начинает её выдавать единственный нормальный способ от этого избавиться - перезапустить эксель полностью, иначе обычно эксель выпадает в авторекавери с ошибкой при практически любом действии (ctrl-c,ctrl-v даже).
Кто-нибудь знает в чем может быть причина?
Вроде макросы нехитрые со стандартными процедурами, вот например:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
Dim IDList As New Collection, lookupRange As Range, cell As Range
Dim ws As Worksheet, wsCompany As Worksheet
Dim wb As Workbook, ID As Variant
If Me.CreateNewFile Then
Dim filename As String
filename = ThisWorkbook.Path & "\" & CStr(Me.cbxPeerGroup.Value) & "Peer.xls"
ThisWorkbook.SaveCopyAs filename
Set wb = Workbooks.Open(filename, False, False, , , , True)
Else
Set wb = ThisWorkbook
End If
Set ws = wb.Worksheets("PeerGroups")
Set wsCompany = wb.Worksheets("Company")
Dim tmp As String
Set lookupRange = ws.Range("1:1").Find(what:=CStr(Me.cbxPeerGroup.Value), lookat:=xlWhole)
Set lookupRange = lookupRange.EntireColumn.SpecialCells(xlCellTypeConstants)
Set lookupRange = lookupRange.Offset( 1 , 0 ).Resize(lookupRange.Rows.Count - 1 )
On Error Resume Next
For Each cell In lookupRange
tmp = wsCompany.Range("B:B").Find(CStr(cell.Value), , , xlWhole).Offset( 0 , - 1 )
IDList.Add tmp, tmp
Next
Set lookupRange = wsCompany.Range(wsCompany.Range("A2"), wsCompany.Range("A65536").End(xlUp))
For Each cell In lookupRange
On Error GoTo removeIfWhatWeNeed
IDList.Add CStr(cell.Value), CStr(cell.Value)
GoTo nxt
removeIfWhatWeNeed:
IDList.Remove CStr(cell.Value)
Err.Clear
Resume Next
nxt:
Next
On Error GoTo 0
' to make peer group
Dim wsData As Worksheet
Dim fRange As Range
Dim toDel As Range
Dim toDelTotal As Range
Set wsData = wb.Worksheets("Data")
Set fRange = wsData.Range("A1")
For Each ID In IDList
On Error Resume Next
wsData.ShowAllData
fRange.AutoFilter field:= 1 , Criteria1:=ID
Set toDel = wsData.Range("A2:A65536").SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible)
If toDelTotal Is Nothing Then
Set toDelTotal = toDel
Else
Set toDelTotal = Union(toDelTotal, toDel)
End If
Next
wsData.ShowAllData
toDelTotal.EntireRow.Delete
wb.Worksheets("Statistics").Range("D:IV").Delete
wb.Worksheets("Statistics").Range("C:C").ClearContents
wb.Worksheets("Statistics JF").Range("D:IV").Delete
wb.Worksheets("Statistics JF").Range("C:C").ClearContents
Unload Me
