|
|
Регистрация Восстановить пароль |
Повторная активизация e-mail |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
|
Опции темы | Поиск в этой теме |
03.09.2009, 23:49 | #1 |
Пользователь
Регистрация: 03.09.2009
Сообщений: 10
|
Макрос умирает после сортировки
В общем дело обстоит так. Макрос без сортировки работает изумительно. Как только делаешь с файлом сортировку всё работать перестаёт. И не важно сортировалось этим же макросом или удалил от туда эту часть и отсортировал потом в ручную - эффект тот же. При этом сортировка выполняется обсолютно правильно, т.е. сортируются строчки, а не отдельно взятые столбцы.
Ни какие танцы с бубмном не смогли заставить работать макрос после сорта, но в данном случае сортировка просто необходима. Может её можно выполнить при помощи какого-то кода, а не стандартными средствами Офиса? У кого есть мысли делитесь не стесняйтесь, буду благодарен за любые высказывания в тему... Текст макроса: 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 Последний раз редактировалось Skandalius; 04.09.2009 в 23:00. |
04.09.2009, 20:28 | #2 |
Участник клуба
Регистрация: 10.08.2009
Сообщений: 1,796
|
Здравствуйте Skandalius.
для чего предназначен Ваш код который "без сортировки работает изумительно"? Без понимания назначения разбираться и вникать во все тонкости, к тому же "умирающей" конструкции сомневаюсь, что кому-то захочется. Евгений. P.S.если для ознакомления необходимо выложить код, заключайте его в тэги [сode]...[/сode] для удобочитаемости. |
04.09.2009, 22:57 | #3 |
Пользователь
Регистрация: 03.09.2009
Сообщений: 10
|
Евгений, спасибо за отзывчивость
Как мне представляется сам код тут ни причём, т.к. по отдельности он работает. Вся суть в том, что после сортировки с документом что-то происходит. Суть кода сводится к следующему: Сначала на листе 2 он находит пустые ячейки в 3-тем столбце и удаляет их, затем (это основное его назначение) сравнивает значения второго листа 3-го столбца с 3-тим листом вторым столбцом и если находит совпадение то заменяет 6-ую ячейку 2-го листа на пятую 3-го, если не находит то на втором личте закрашивает в жолтый, если на третем есть запись которой нет на втором, то копирует её на второй и окрашивает в зелёный. Все окрашенные записи оказываются внизу таблицы. (Вот эта часть работает просто изумительно) Дальше макрос (можно и в ручную с темже эффектом) сортирует строки 2-го листа сначало по второму столбцу, затем по третьему, затем по 4-уму. И делает это обсолютно коректно. Но фот после этого начинается крень. Если опять запустить перенос таблицы, то он просто переносит всё с 3-го листа на второй по верх всего и окрашивает в зелёный. Если сортировку не делать, то всё будет работать сколько вашей душе угодно раз. Но вся беда в том, что сортировка нужна. Как подробней я не знаю. Если есть идеи делитесь буду рад любым... |
05.09.2009, 14:36 | #4 |
Участник клуба
Регистрация: 10.08.2009
Сообщений: 1,796
|
Здравствуйте Skandalius.
если информация не конфиденциальна, выложите архив с Вашим файлом, возможно решение найдется быстрее. Евгений. |
05.09.2009, 22:13 | #5 |
Пользователь
Регистрация: 03.09.2009
Сообщений: 10
|
Евгений, выложить этот файл в интернете не имею ни малейшего права Но если вы готовы попробовать помочь, то скажите куда его вам отправить и я перешлю. Это касается и других пользователей у которых есть идеи на эту тему.
|
05.09.2009, 22:28 | #6 |
Старожил
Регистрация: 02.05.2009
Сообщений: 3,907
|
http://94.248.65.245/
Увидите папку Для закачки,закачайте файл через браузер Ссылка актуальна в течении часа
Анализ,обработка данных Недорого
|
05.09.2009, 23:35 | #7 |
Пользователь
Регистрация: 03.09.2009
Сообщений: 10
|
Файл загружается. Там последняя часть макроса* работает только в 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 |
05.09.2009, 23:44 | #8 |
Старожил
Регистрация: 02.05.2009
Сообщений: 3,907
|
По тому же адресу качните себе на всякий случай HTTP сервер
hfs2.2d_Rus Вдруг не пройдет закачка,у меня фревол строгий Запустите,добавите свой файл и мне Ваш IP адрес,я тогда себе попробую скачать
Анализ,обработка данных Недорого
|
05.09.2009, 23:57 | #9 |
Пользователь
Регистрация: 03.09.2009
Сообщений: 10
|
Так что ли?
http://95.79.4.232:8080/%D0%A3%D1%87...0%BE%D0%B2.xls Кстати по той ссылке файл не загрузился |
06.09.2009, 00:18 | #10 |
Старожил
Регистрация: 02.05.2009
Сообщений: 3,907
|
Получил.На будущее,файл надо архивировать,тогда он будет в 10 раз меньше,при татой обратной закачке имя тольно английскими буквами,эта программа русифицирована,а не русская
Анализ,обработка данных Недорого
|
|
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Макрос постоянно обрабатывает события. При открытии другой книги макрос обрывается. | Ples | Microsoft Office Excel | 8 | 17.12.2016 18:15 |
Макрос сортировки строк по листам | noname_06 | Microsoft Office Excel | 8 | 24.01.2009 20:30 |
Макрос сохранения после печати | lala_white | Microsoft Office Word | 2 | 10.08.2008 12:50 |
for SAS888 please help! макрос выделения цифр жирным шрифтом прописывает числа без нулей после запятой | Dorvir | Microsoft Office Excel | 1 | 03.03.2008 22:39 |
Винчестер умирает? | Viteef | Компьютерное железо | 23 | 29.02.2008 11:43 |