Здравствуйте,
год макрос работал идеально, но последние несколько дней зависает. Смысл макроса: есть 3 листа. Сначала макрос фильтрует лист 1 по цвету и сравнивает его с 2м, потом фильтрует заново лист 1 по другому цвету и сравнивает его с 3м.
при открытии файла все работает. Но если удалить хоть 1ну строчку любого листа - зависает.
Если принудительно остановить, то пишет "method "apply" of object "sort" failed".
Добавлю, все это произошло после апдейтов Оффиса (32-разрядная версия).
удалил кусок, который глючит:
Код:
ActiveWorkbook.Worksheets("SHEEET2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("SHEEET2").Sort.SortFields.Add Key:=Range("B1"), SortOn _
:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("SHEEET2").Sort
.SetRange Range("A2:AB7777")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
если удалить весь кусок из макроса, то ошибка другая: "method "calculate" of object "_Worksheet" failed"
В чем причина? Как исправить?
вот сам макрос:
Код:
Dim i As Long, j As Long, a(), b$, c$
Dim tmp As Worksheet, rangeOne As Range, rangeTwo As Range
Application.EnableEvents = False
Sheets("SHEEET1").Select
Columns("A:AA").Select
Selection.EntireColumn.Hidden = False
Sheets("SHEEET2").Select
Columns("A:AA").Select
Selection.EntireColumn.Hidden = False
Sheets("SHEEET1").Select
ActiveSheet.Range("$A$1:$AA$18999").AutoFilter Field:=1, Criteria1:=RGB(0, 176 _
, 80), Operator:=xlFilterCellColor
Sheets("SHEEET2").Select
Columns("B:B").Select
ActiveWorkbook.Worksheets("SHEEET2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("SHEEET2").Sort.SortFields.Add Key:=Range("B1"), SortOn _
:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("SHEEET2").Sort
.SetRange Range("A2:AB7777")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Set rangeOne = Sheets("SHEEET1").UsedRange
Set rangeTwo = Sheets("SHEEET2").UsedRange
Set rangeOne = rangeOne.SpecialCells(xlCellTypeVisible)
Set rangeTwo = rangeTwo.Offset(, 1).resize(, rangeTwo.Columns.Count - 1)
Set tmp = Sheets.Add
rangeOne.Copy
tmp.Paste
Set rangeOne = tmp.Cells(1).resize(rangeTwo.Rows.Count, rangeTwo.Columns.Count)
b = rangeOne.Address(, , Application.ReferenceStyle, True)
c = rangeTwo.Address(, , Application.ReferenceStyle, True)
a = Evaluate(b & "<>" & c)
Application.DisplayAlerts = False
tmp.Delete
Application.DisplayAlerts = True
For i = 1 To UBound(a)
For j = 1 To UBound(a, 2)
If a(i, j) Then rangeTwo.Cells(i, j).Interior.Color = RGB(255, _
0, 0)
Next j
Next i
Sheets("SHEEET1").Select
ActiveSheet.Range("$A$1:$AA$18999").AutoFilter Field:=1
Sheets("SHEEET2").Select
Sheets("SHEEET1").Select
Columns("G:G").Select
Selection.EntireColumn.Hidden = True
Sheets("SHEEET2").Select
Columns("H:H").Select
Selection.EntireColumn.Hidden = True
Columns("U:U").Select
Selection.EntireColumn.Hidden = True
Columns("O:P").Select
Selection.EntireColumn.Hidden = True
Range("A1").Select
Selection.Copy
Range("B1:AA1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("a2:a3").AutoFill Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
Application.CutCopyMode = False
'=====================================
Sheets("SHEEET1").Select
Columns("A:AA").Select
Selection.EntireColumn.Hidden = False
Sheets("SHEEET3").Select
Columns("A:AA").Select
Selection.EntireColumn.Hidden = False
Sheets("SHEEET1").Select
ActiveSheet.Range("$A$1:$AA$18999").AutoFilter Field:=1, Criteria1:=RGB(255, _
0, 0), Operator:=xlFilterCellColor
Sheets("SHEEET3").Select
Columns("B:B").Select
ActiveWorkbook.Worksheets("SHEEET3").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("SHEEET3").Sort.SortFields.Add Key:=Range("B1"), SortOn _
:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("SHEEET3").Sort
.SetRange Range("A2:AB699")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Set rangeOne = Sheets("SHEEET1").UsedRange
Set rangeTwo = Sheets("SHEEET3").UsedRange
Set rangeOne = rangeOne.SpecialCells(xlCellTypeVisible)
Set rangeTwo = rangeTwo.Offset(, 1).resize(, rangeTwo.Columns.Count - 1)
Set tmp = Sheets.Add
rangeOne.Copy
tmp.Paste
Set rangeOne = tmp.Cells(1).resize(rangeTwo.Rows.Count, rangeTwo.Columns.Count)
b = rangeOne.Address(, , Application.ReferenceStyle, True)
c = rangeTwo.Address(, , Application.ReferenceStyle, True)
a = Evaluate(b & "<>" & c)
Application.DisplayAlerts = False
tmp.Delete
Application.DisplayAlerts = True
For i = 1 To UBound(a)
For j = 1 To UBound(a, 2)
If a(i, j) Then rangeTwo.Cells(i, j).Interior.Color = RGB(0, 176 _
, 80)
Next j
Next i
Sheets("SHEEET1").Select
ActiveSheet.Range("$A$1:$AA$18999").AutoFilter Field:=1
Sheets("SHEEET3").Select
Sheets("SHEEET1").Select
Columns("G:G").Select
Selection.EntireColumn.Hidden = True
Sheets("SHEEET3").Select
Columns("H:H").Select
Selection.EntireColumn.Hidden = True
Columns("U:U").Select
Selection.EntireColumn.Hidden = True
Range("A1").Select
Selection.Copy
Range("B1:AA1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("a2:a3").AutoFill Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
Application.CutCopyMode = False
_____
Код программы нужно выделять (форматировать) тегами [CODE] (читать FAQ)
Модератор