Макрос умирает после сортировки

[Skandalius]

В общем дело обстоит так. Макрос без сортировки работает изумительно. Как только делаешь с файлом сортировку всё работать перестаёт. И не важно сортировалось этим же макросом или удалил от туда эту часть и отсортировал потом в ручную - эффект тот же. При этом сортировка выполняется обсолютно правильно, т.е. сортируются строчки, а не отдельно взятые столбцы.

Ни какие танцы с бубмном не смогли заставить работать макрос после сорта, но в данном случае сортировка просто необходима. Может её можно выполнить при помощи какого-то кода, а не стандартными средствами Офиса? У кого есть мысли делитесь не стесняйтесь, буду благодарен за любые высказывания в тему...

Текст макроса:

Function FindID(ByRef Arr, ID)
FindID = 0
For i = 2 To UBound(Arr)
If Arr(i) = ID Then
FindID = i
Exit For
End If
Next i
End Function
Sub Main()
ActiveSheet.Range("$A$1:$O$10934"). AutoFilter Field:=5, Criteria1:="="
Rows("2:11062").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$1:$O$9196").A utoFilter Field:=5
Range("A1").Select

Dim Arr1()
Dim Arr2()

Dim nRow1 'кол-во строк в первом листе
Dim nRow2
nRow1 = Worksheets(2).Columns(1).End(xlDown ).Row
nRow2 = Worksheets(3).Columns(1).End(xlDown ).Row

ReDim Arr1(2 To nRow1) 'массив л/с первого листа
ReDim Arr2(2 To nRow2)
For i = 2 To nRow1
Arr1(i) = Worksheets(2).Cells(i, 5).Text 'Cells(i, 4- столбец
Next i
For i = 2 To nRow2
Arr2(i) = Worksheets(3).Cells(i, 4).Text
Next i

par1 = 0 'счетчик замен
par2 = 0 'счетчик удалений/закрашиваний
par3 = 0 'счетчик добавленных строк

Dim currFind 'номер строки в которой найден нужный л/с
For i = nRow1 To 2 Step -1
currFind = FindID(Arr2, Arr1(i))
If currFind > 0 Then 'нашли строку с нов. знач.
Worksheets(2).Cells(i, 10).Value = Worksheets(3).Cells(currFind, 9).Value '9 - номер столбца в новом файле, Worksheets- номера листов
Worksheets(2).Cells(i, 11).Value = Worksheets(3).Cells(currFind, 10).Value
par1 = par1 + 1
Else 'не нашли
'Row(i).Delete 'удаляем строку
Worksheets(2).Range("A" & i & ":I" & i).Interior.ColorIndex = 46 'закрашиваем
par2 = par2 + 1
End If
Next i

Dim currMaxRow1 'последняя строка с учетом добавлений
currMaxRow1 = nRow1

For i = 2 To nRow2
currFind = FindID(Arr1, Arr2(i))
If currFind = 0 Then 'не нашли строку
currMaxRow1 = currMaxRow1 + 1
Worksheets(2).Cells(currMaxRow1, 2).Value = Worksheets(3).Cells(i, 1).Value
Worksheets(2).Cells(currMaxRow1, 3).Value = Worksheets(3).Cells(i, 2).Value
Worksheets(2).Cells(currMaxRow1, 4).Value = Worksheets(3).Cells(i, 3).Value
Worksheets(2).Cells(currMaxRow1, 5).Value = Worksheets(3).Cells(i, 4).Value
Worksheets(2).Cells(currMaxRow1, 6).Value = Worksheets(3).Cells(i, 5).Value
Worksheets(2).Cells(currMaxRow1, 7).Value = Worksheets(3).Cells(i, 6).Value
Worksheets(2).Cells(currMaxRow1, 8).Value = Worksheets(3).Cells(i, 7).Value
Worksheets(2).Cells(currMaxRow1, 9).Value = Worksheets(3).Cells(i, 8).Value
Worksheets(2).Cells(currMaxRow1, 10).Value = Worksheets(3).Cells(i, 9).Value
Worksheets(2).Cells(currMaxRow1, 11).Value = Worksheets(3).Cells(i, 10).Value


Worksheets(2).Range("A" & currMaxRow1 & ":I" & currMaxRow1).Interior.ColorIndex = 10 'закрашиваем

par3 = par3 + 1
End If
Next i

Columns("A:O").Select
ActiveWorkbook.Worksheets("3").Sort .SortFields.Clear
ActiveWorkbook.Worksheets("3").Sort .SortFields.Add Key:=Range( _
"B2:B11335"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("3").Sort .SortFields.Add Key:=Range( _
"C2:C11335"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("3").Sort .SortFields.Add Key:=Range( _
"D2:D11335"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("3").Sort
.SetRange Range("A1:O11335")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2").Select

MsgBox "замен: " & par1 & vbCrLf & "удалено: " & par2 & vbCrLf & "добавлено: " & par3

End Sub

[Teslenko_EA]

Здравствуйте Skandalius.
для чего предназначен Ваш код который "без сортировки работает изумительно"? Без понимания назначения разбираться и вникать во все тонкости, к тому же "умирающей" конструкции сомневаюсь, что кому-то захочется.
Евгений.
P.S.если для ознакомления необходимо выложить код, заключайте его в тэги [сode]...[/сode] для удобочитаемости.

[Skandalius]

Евгений, спасибо за отзывчивость

Как мне представляется сам код тут ни причём, т.к. по отдельности он работает. Вся суть в том, что после сортировки с документом что-то происходит.

Суть кода сводится к следующему: Сначала на листе 2 он находит пустые ячейки в 3-тем столбце и удаляет их, затем (это основное его назначение) сравнивает значения второго листа 3-го столбца с 3-тим листом вторым столбцом и если находит совпадение то заменяет 6-ую ячейку 2-го листа на пятую 3-го, если не находит то на втором личте закрашивает в жолтый, если на третем есть запись которой нет на втором, то копирует её на второй и окрашивает в зелёный. Все окрашенные записи оказываются внизу таблицы. (Вот эта часть работает просто изумительно) Дальше макрос (можно и в ручную с темже эффектом) сортирует строки 2-го листа сначало по второму столбцу, затем по третьему, затем по 4-уму. И делает это обсолютно коректно. Но фот после этого начинается крень. Если опять запустить перенос таблицы, то он просто переносит всё с 3-го листа на второй по верх всего и окрашивает в зелёный. Если сортировку не делать, то всё будет работать сколько вашей душе угодно раз. Но вся беда в том, что сортировка нужна.

Как подробней я не знаю. Если есть идеи делитесь буду рад любым...

[Teslenko_EA]

Здравствуйте Skandalius.
если информация не конфиденциальна, выложите архив с Вашим файлом, возможно решение найдется быстрее.
Евгений.

[Skandalius]

Евгений, выложить этот файл в интернете не имею ни малейшего права Но если вы готовы попробовать помочь, то скажите куда его вам отправить и я перешлю. Это касается и других пользователей у которых есть идеи на эту тему.

[doober]

http://94.248.65.245/
Увидите папку Для закачки,закачайте файл через браузер
Ссылка актуальна в течении часа

[Skandalius]

Файл загружается. Там последняя часть макроса* работает только в 2007, для 2003 её надо удалить и сделать сартировку вручную по 2,3 и 4 столбкам


* Вот этот фрагмент:
Columns("A:O").Select
ActiveWorkbook.Worksheets("3").Sort .SortFields.Clear
ActiveWorkbook.Worksheets("3").Sort .SortFields.Add Key:=Range( _
"B2:B11335"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("3").Sort .SortFields.Add Key:=Range( _
"C2:C11335"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("3").Sort .SortFields.Add Key:=Range( _
"D2:D11335"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("3").Sort
.SetRange Range("A1:O11335")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2").Select

[doober]

По тому же адресу качните себе на всякий случай HTTP сервер
hfs2.2d_Rus Вдруг не пройдет закачка,у меня фревол строгий
Запустите,добавите свой файл и мне Ваш IP адрес,я тогда себе попробую скачать

[Skandalius]

Так что ли?
http://95.79.4.232:8080/%D0%A3%D1%87...0%BE%D0%B2.xls

Кстати по той ссылке файл не загрузился

[doober]

Получил.На будущее,файл надо архивировать,тогда он будет в 10 раз меньше,при татой обратной закачке имя тольно английскими буквами,эта программа русифицирована,а не русская