Добрый день! Есть классификатор и отчет который выдает данные + код группы артикула. Групп 2500 фамилий 6 Каждый раз вприть муторно, написал код ( макрорекодером найти и заменить) На самом деле 3 кода т.к. есть ограничение VBA на количество строк (бью на 3 SUB) С небольшим отчетом все прелесно, но если строчек около или больше 1000 ... то проще открывать классификато и вприть...
Добрый. Править макрос лучше на файле с расположением данных, как у Вас в оригинале. Покажите кусок данных в файле, укажите, что на что и где надо заменить. Мне лично пока не очень понятно...
если возможно получить непосредственно предмет замены(допустим, номер ячейки или как то так), то можно избежать многократного прохода по содержимому - сйчас у вас каждая строка Selection.Replace - это цикл перебора всего содержимого, сравнения его с заданным и замены при совпадении
если мы знаем, что элемент X требуется заменить, если он входит в заранее определенный список замен, то можно пройти всего один раз, каждый раз заменяя нужное. те вместо поиска по всему содержимому, мы проводим поиск только по небольшому списку замен
Вводная код - фамилия Кодов 2500 фамилий 6. 1я мысль была макрос открывает классификатор, вприт выделенный диапзон, сохраняет как значение. 2. Засунуть в код все данные... Пошел по второму пути....
Когда я ем,я глух и нем, хитер и быстр, и дьявольски умен.
Можно как-то так (я постарался подробно расписать):
Код
Sub MonsterBeer()
Dim objC As Range
Dim arrA()
Dim intI As Integer
'проверяем, чтобы в выделении не было больше одного столбца
If Selection.Columns.Count > 1 Then
MsgBox "В выделении не должно быть более одного столбца"
Exit Sub
End If
'забираем таблицу соответствий в массив
arrA = Range("I3:J9")
'для каждой ячееки в выделении
For Each objC In Selection
'для каждого левого элемента таблицы соответствий
For intI = LBound(arrA, 1) To UBound(arrA, 1)
'если элемент таблицы равен ячейке слева от текущей
If arrA(intI, 1) = objC.Offset(0, -1).Value Then
'заменяем значение текущей правым значением из таблицы соответствий
objC.Value = arrA(intI, 2)
'и выходим из цикла, переходим к следующей ячейке в выделении
Exit For
End If
'а если нет - проверяем следующее значение таблицы соответствий
Next intI
Next
End Sub
Можно, конечно, только как вы его будете заполнять при инициализации процедуры? Циклом забивать каждый элемент код-значение? З.Ы. Мне кажется (пусть меня поправят), что таблицу с классификатором совершенно не обязательно открывать, нет? ПолныйПуть.имяфайла.имялиста.диапазон а?
MonsterBeer написал: Есть мысли как упростить код?
Код
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim cl As Range
Dic.CompareMode = vbTextCompare
Dic.Add "DAX", "ФИО1"
Dic.Add "DAZ", "ФИО2"
Dic.Add "DBI", "ФИО2"
Dic.Add "DDB", "ФИО3"
Dic.Add "DDC", "ФИО2"
Dic.Add "DDF", "ФИО3"
Dic.Add "DDG", "ФИО"
Dic.Add "DDH", "ФИО3"
For Each cl In Selection
If Dic.exists(cl.Value) Then cl.Value = Dic(cl.Value)
Next cl
Set Dic = Nothing
End Sub
Если 2500 - это список замен, да ещё и фамилии... Не придётся ли пару раз в неделю лазить в код? Я бы держал его в текстовом файле или тут же где-то на листе (можно скрытом) - так проще его править, а по скорости и не заметите. В словарь его, и меняем.... Как выше показали.
Ничёнепонимаю. Нафига все эти замены? Задача чисто под ВПР. Вариант с макросом - записать рекордером вставку ВПР с нужными параметрами в нужный диапазон, нажимать кнопку и радоваться. Весь макрос - 2 строчки. Вариант без макроса - скопировать готовую формулу в блокнот и вставлять оттуда сразу в нужный диапазон.
Код
Sub Макрос1()
With Range(Cells(3, 2), Cells(Rows.Count, 2).End(xlUp)).Offset(, 1)
.FormulaR1C1 = "=VLOOKUP(RC[-1],R3C9:R9C10,2,0)"
.Value = .Value
End With
End Sub
MonsterBeer написал: Макрос реализован в надстройке, а как мне закинуть данные справочника на этот лист, а потом еще и обратится к нему?
Создайте файл xlsx например (СправочникЗамен.xlsx), внесите в него список замен, сохраните его в формате хlam, добавьте надстройку, затем как в коде ниже.
Код
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim cl As Range
Dic.CompareMode = vbTextCompare
With Workbooks("СправочникЗамен.xlam").Sheets("Лист1")
For Each cl In .[A1:A8]
Dic.Add cl.Value, cl.Offset(, 1).Value
Next cl
End With
For Each cl In Selection
If Dic.exists(cl.Value) Then cl.Value = Dic(cl.Value)
Next cl
Set Dic = Nothing
End Sub