если в вашем рабочем файле структура такая же, как в файле-примере
к сожалению нет, столбцы разделены другими данными. на скрепке данные с исходной структурой поясните, пожалуйста, как задать нужные диапазоны данных в исходной структуре
как я уже писал, вчера пробовал первый вариант макроса от KSV на 47К строк: MS office 2013 x64 работал около 40мин, обработав 93% строк затем офис повис... тем не менее можно обрабатывать порции данных по 1К-3К строк
если в вашем рабочем файле структура такая же, как в файле-примере
к сожалению нет, столбцы разделены другими данными. на скрепке данные с исходной структурой поясните, пожалуйста, как задать нужные диапазоны данных в исходной структуре
как я уже писал, вчера пробовал первый вариант макроса от KSV на 47К строк: MS office 2013 x64 работал около 40мин, обработав 93% строк затем офис повис... тем не менее можно обрабатывать порции данных по 1К-3К строк
Sub generateMark() ' столбцы данных: 01 date, 14 name, 15 place, 26 vol, 32 mark ' строка начала данных: 46 + 1 startRow = 47 Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = 1 Application.ScreenUpdating = False With ActiveSheet Set lastCell = .Cells.SpecialCells(xlLastCell) Range(.Cells(startRow, 32), .Cells(lastCell.Row, 32)).Clear For r = startRow To lastCell.Row currName = .Cells(r, 14).Value If Len(Trim(currName)) > 0 Then currPlace = .Cells(r, 15).Value currVol = .Cells(r, 26).Value If dict.exists(currName) Then .Cells(r, 32).Value = "b" If currPlace <> 1 And currVol = "m" Then dict(currName) = r End If If r Mod 10000 = 0 Then Application.StatusBar = "Выполняется..." & Round(100 * (r - startRow - 1) / (lastCell.Row - startRow - 1), 1) & "%" Next Application.StatusBar = "Готово" End With Application.ScreenUpdating = True End Sub
Sub generateMark() ' столбцы данных: 01 date, 14 name, 15 place, 26 vol, 32 mark ' строка начала данных: 46 + 1 startRow = 47 Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = 1 Application.ScreenUpdating = False With ActiveSheet Set lastCell = .Cells.SpecialCells(xlLastCell) Range(.Cells(startRow, 32), .Cells(lastCell.Row, 32)).Clear For r = startRow To lastCell.Row currName = .Cells(r, 14).Value If Len(Trim(currName)) > 0 Then currPlace = .Cells(r, 15).Value currVol = .Cells(r, 26).Value If dict.exists(currName) Then .Cells(r, 32).Value = "b" If currPlace <> 1 And currVol = "m" Then dict(currName) = r End If If r Mod 10000 = 0 Then Application.StatusBar = "Выполняется..." & Round(100 * (r - startRow - 1) / (lastCell.Row - startRow - 1), 1) & "%" Next Application.StatusBar = "Готово" End With Application.ScreenUpdating = True End Sub
Вот, я не понимаю, для чего давать некий "абстрактный" пример, если потом все равно сам не сможешь адаптировать полученное решение к своему рабочему файлу? Вы, конечно, здесь не один такой, но может хоть Вы мне объясните?... [p.s.]Прокомментировал для Вас каждую строчку кода[/p.s.]
Вот, я не понимаю, для чего давать некий "абстрактный" пример, если потом все равно сам не сможешь адаптировать полученное решение к своему рабочему файлу? Вы, конечно, здесь не один такой, но может хоть Вы мне объясните?... [p.s.]Прокомментировал для Вас каждую строчку кода[/p.s.]KSV
Вот, я не понимаю, для чего давать некий "абстрактный" пример,
На момент обращения на форум этого примера казалось вполне достаточно, что-то вроде: "ну, пару-то столбцов я смогу переназначить в макросе, палюбому!" Просто Ваше знание VBA и манера написания кода на порядок лучше моего и многих пользователей офиса. Так что не стоит сердиться.
Второй макрос сработал гораздо лучше: excel задумался на 4мин, затем расставил маркеры где положено) За помощь большое спасибо
Вот, я не понимаю, для чего давать некий "абстрактный" пример,
На момент обращения на форум этого примера казалось вполне достаточно, что-то вроде: "ну, пару-то столбцов я смогу переназначить в макросе, палюбому!" Просто Ваше знание VBA и манера написания кода на порядок лучше моего и многих пользователей офиса. Так что не стоит сердиться.
Второй макрос сработал гораздо лучше: excel задумался на 4мин, затем расставил маркеры где положено) За помощь большое спасибоHiHiMAX
Сообщение отредактировал HiHiMAX - Среда, 09.09.2015, 18:55
Это много. У меня, на слабом компе, на тестовом примере в 300 тыс. - код отработал за пару десятков секунд. Могу предположить, что у вас какие-то ещё формулы/эвенты завязаны на столбец с маркером, а автоперерасчет вы на время работы макроса - не отключили...
Это много. У меня, на слабом компе, на тестовом примере в 300 тыс. - код отработал за пару десятков секунд. Могу предположить, что у вас какие-то ещё формулы/эвенты завязаны на столбец с маркером, а автоперерасчет вы на время работы макроса - не отключили...AndreTM
Ну, да, 4 мин. – это многовато... Попробуйте вариант со словарем (должно быть гораздо быстрее) [vba]
Код
Option Base 1
Sub Проставить_Маркеры() Dim i&, s$, p(), v(), dic As Object Set dic = CreateObject("Scripting.Dictionary") i = [N46].End(xlDown).Row ' получаем номер последней заполненной строки p = Range("N47:O" & i) ' считываем в массив данные столбцов N и O v = Range("Z47:Z" & i) ' считываем в массив данные столбца Z For i = 1 To UBound(v) ' просматриваем массив, от первой строки до последней s = p(i, 1) ' сохраняем искомое имя участника в переменную (т.к. доступ к значению переменной чуть быстрее, чем доступ к значению двухмерного массива) p(i, 1) = dic(s) ' получаем результат предыдущего испытания искомого участника dic(s) = IIf(p(i, 2) <> 1 And v(i, 1) = "m", "b", Empty) ' запоминаем результат предыдущего испытания искомого участника Next [AF47].Resize(i - 1) = p ' выводим маркеры на лист Excel End Sub
[/vba]
Ну, да, 4 мин. – это многовато... Попробуйте вариант со словарем (должно быть гораздо быстрее) [vba]
Код
Option Base 1
Sub Проставить_Маркеры() Dim i&, s$, p(), v(), dic As Object Set dic = CreateObject("Scripting.Dictionary") i = [N46].End(xlDown).Row ' получаем номер последней заполненной строки p = Range("N47:O" & i) ' считываем в массив данные столбцов N и O v = Range("Z47:Z" & i) ' считываем в массив данные столбца Z For i = 1 To UBound(v) ' просматриваем массив, от первой строки до последней s = p(i, 1) ' сохраняем искомое имя участника в переменную (т.к. доступ к значению переменной чуть быстрее, чем доступ к значению двухмерного массива) p(i, 1) = dic(s) ' получаем результат предыдущего испытания искомого участника dic(s) = IIf(p(i, 2) <> 1 And v(i, 1) = "m", "b", Empty) ' запоминаем результат предыдущего испытания искомого участника Next [AF47].Resize(i - 1) = p ' выводим маркеры на лист Excel End Sub