Макрос - аналог ВПР

Дата: Вторник, 29.03.2016, 15:08 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Коллеги, друзья, сочувствующие! Помогите дебилу, в приложении архив с двумя файлами, "пример классификатора.xlsx" как база, "файл 2.xlsx" как файл с макросом, запускаем его.
При нажатии на стрелку, запускается макрос, вводим номер столбца из классификатора, и выбираем сам файл с классификатором. В итоге получается аналог ВПР.
Всего макрос рассчитан на 4 столбца, а нужно получить неограниченное кол-во столбцов, т.к. классификатор будет всегда разный, иметь и по 10-20 столбцов.
Кто может внести изменения?

К сообщению приложен файл: 9327055.zip (45.8 Kb)

Дата: Вторник, 29.03.2016, 16:14 | Сообщение № 2

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290

Репутация: 766 ±

Замечаний: 0% ±

2019

Цитата Лойер, 29.03.2016 в 15:08, в сообщении № 1

рассчитан на 4 столбца

Макрос подтягивает по одному столбцу.
Вам нужно просто увеличить диапазон выбора с 4-х до 20?
Или чтоб подтягивал сразу все 20-ть?
Если 1-е, то удалите строку:
[vba]

Код

If clmn < 2 Or clmn > 5 Then MsgBox "Нет такого столбца", 64: Exit Sub

[/vba]
и поменяйте
[vba]

Код

x = .Range("A2:E" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
на
x = .Range("A2:z" & .Cells(Rows.Count, 1).End(xlUp).Row).Value

[/vba]

К сообщению приложен файл: _2.xlsm (24.6 Kb)

Иногда все проще чем кажется с первого взгляда.

Дата: Среда, 30.03.2016, 08:13 | Сообщение № 3

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

SLAVICK, огромное спасибо, теперь все как надо.
Вот еще какая мысль пришла в голову, а что если классификатор будет находиться не в другом файле, а допустим на новом листе, можно ли как то модернизировать под это макрос?
Понятно, что ВПР будет здесь уместнее, но интересует именно макрос.

Дата: Среда, 30.03.2016, 09:33 | Сообщение № 4

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290

Репутация: 766 ±

Замечаний: 0% ±

2019

Цитата Лойер, 30.03.2016 в 08:13, в сообщении № 3

Понятно, что ВПР будет здесь уместнее

Вообще то Впр прекрасно справляется и с 1-й задачей :D
если хотите использовать Ваш макрос:
удалите блок
[vba]

Код

With Application.FileDialog(msoFileDialogFilePicker)    'классификатор
    .Title = "Выбираем файл-классификатор": .InitialFileName = ThisWorkbook.Path
    .Filters.Add "Excel", "*.xls;*.xlsx;*.xlsm", 1: .AllowMultiSelect = False
    If .Show = False Then Exit Sub: If .SelectedItems.Count = 0 Then Exit Sub
    Set wb = GetObject(.SelectedItems(1))
End With

[/vba]Добавьте строку выбора листа:
[vba]

Код

i = InputBox("номер листа с информацией", , 1)

[/vba]
и вместо:
[vba]

Код

With wb.Sheets(1)
напишите:
With Sheets(i)

[/vba]

[offtop]А вообще, как по мне -этот макрос очень не удобный, и я бы использовал совсем другой алгоритм - словарь... но тема не о том.[/offtop]

К сообщению приложен файл: _2-2-.xlsm (67.7 Kb)

Иногда все проще чем кажется с первого взгляда.

Дата: Среда, 30.03.2016, 11:05 | Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Цитата SLAVICK, 30.03.2016 в 09:33, в сообщении № 4

Вообще то Впр прекрасно справляется и с 1-й задачей :D

Бесспорно, но решили попробовать макросом снизить объем файла и время "обдумывания". Очень большой объем информации, ВПР просто не справляется, все зависает на полдня.
В итоге, с помощью ваших советов и корректировок объем не снизили почти, но время реагирования снизили в разы. Спасибо вам большое! hands

Дата: Четверг, 31.03.2016, 15:03 | Сообщение № 6

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

SLAVICK, после тестирования этого макроса, обнаружил вот какой косяк..если в "базе" номера в первом столбце будут идти не по возрастанию, то все работает криво, что то он подтягивает, а что то нет, никакой логичности не нашел. Будьте добры, посмотрите что не так?

Дата: Четверг, 31.03.2016, 17:41 | Сообщение № 7

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290

Репутация: 766 ±

Замечаний: 0% ±

2019

Цитата Лойер, 31.03.2016 в 15:03, в сообщении № 6

обнаружил вот какой косяк..если в "базе" номера в первом столбце будут идти не по возрастанию, то все работает криво

Цитата SLAVICK, 30.03.2016 в 09:33, в сообщении № 4

я бы использовал совсем другой алгоритм - словарь

как то так:
[vba]

Код

Sub ertert()
Dim wb As Object
Dim x, y, z(), i&, j&, bu As Boolean
Dim ubx&, lbx&, clmn&
Dim dic As New Dictionary
dic.CompareMode = TextCompare
clmn = Application.InputBox("Введите номер столбца ", _
                            "Столбец для поиска", 2, Type:=1)
Application.ScreenUpdating = False
i = InputBox("номер листа с информацией", , 1)
With Sheets(i)
    x = .Range("A2:z" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value 'где ищем
End With
'x = Application.InputBox("выберите диапазон", , , , , , , 8)
'tm = Timer
y = Range([a2], Cells(Rows.Count, 1).End(xlUp)).Value    'что ищем
ReDim z(1 To UBound(y), 1 To 1)

'Заганяем массив x в словарь
For i = 1 To UBound(x)
    If Not dic.Exists(CStr(x(i, 1))) Then dic.Add CStr(x(i, 1)), i
Next
'если есть данные в словаре - записываем данные в z
ReDim z(1 To UBound(y), 1 To 1)

For i = 1 To UBound(y)
    If dic.Exists(CStr(y(i, 1))) Then z(i, 1) = x(dic(CStr(y(i, 1))), clmn)
Next

[a2].Offset(, clmn - 1).Resize(UBound(y)) = z
Application.ScreenUpdating = True
End Sub

[/vba]
Зы если макрос не будет работать - подключите библиотеку Microsoft Scripting Runtime
В tools--reference

Подкорректировал немного.

К сообщению приложен файл: 1419469-1-.xlsm (68.4 Kb)

Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICK - Четверг, 31.03.2016, 17:55

Дата: Вторник, 05.04.2016, 08:47 | Сообщение № 8

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

SLAVICK, спасибо, теперь все грамотно работает.

Hugo

Дата: Вторник, 05.04.2016, 08:59 | Сообщение № 9

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Вместо
[vba]

Код

If Not dic.Exists(CStr(x(i, 1))) Then dic.Add CStr(x(i, 1)), i

[/vba]
я обычно применяю
[vba]

Код

dic.item(trim(x(i, 1))) = i

[/vba]
так меньше преобразований и проверок, и заодно от косяков с пробелами подстрахуетесь.
Ну и при проверке тоже аналогично откидываем пробелы, можно использовать временную переменную, чтоб два раза не откидывать.

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Дата: Вторник, 05.04.2016, 09:49 | Сообщение № 10

Группа: Модераторы

Ранг: Старожил

Сообщений: 2290

Репутация: 766 ±

Замечаний: 0% ±

2019

Цитата Hugo, 05.04.2016 в 08:59, в сообщении № 9

и заодно от косяков с пробелами подстрахуетесь

У меня в процедуре ВПРа (не этой, а которой я пользуюсь) есть несколько режимов, сверки:
точное соответствие,
без знаков пунктуации,
примерное,
содержит.

Иногда нужно чтобы искало "четкое соответствие" - тогда trim - нельзя использовать.
Если нужно искать без пробелов - тогда уж лучше пользоваться replace ом - например будет:
"...ул. правды..." и "...ул.правды..." - трим не спасет - а реплейс поможет

, а еще может быть и "...ул правды..." - тогда мой 2-й режим

По поводу записи сразу dic.item(...- оно немного быстрее, но тут уже дело привычки - возьму себе на заметку попробовать - просто конструкции
[vba]

Код

If ... dic.Exists ...

[/vba]
мне проще для восприятия, и в коде сразу можно обрабатывать условия если False.

Иногда все проще чем кажется с первого взгляда.