Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос - аналог ВПР - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос - аналог ВПР (Макросы/Sub)
Макрос - аналог ВПР
Лойер Дата: Вторник, 29.03.2016, 15:08 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - Лойер
Дата добавления - 29.03.2016 в 15:08
SLAVICK Дата: Вторник, 29.03.2016, 16:14 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1962
Репутация: 669 ±
Замечаний: 0% ±

2007,2010,2013,2016
рассчитан на 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(25Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
рассчитан на 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]

Автор - SLAVICK
Дата добавления - 29.03.2016 в 16:14
Лойер Дата: Среда, 30.03.2016, 08:13 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - Лойер
Дата добавления - 30.03.2016 в 08:13
SLAVICK Дата: Среда, 30.03.2016, 09:33 | Сообщение № 4
Группа: Модераторы
Ранг: Старожил
Сообщений: 1962
Репутация: 669 ±
Замечаний: 0% ±

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

Вообще то Впр прекрасно справляется и с 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(68Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
Понятно, что ВПР будет здесь уместнее

Вообще то Впр прекрасно справляется и с 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]

Автор - SLAVICK
Дата добавления - 30.03.2016 в 09:33
Лойер Дата: Среда, 30.03.2016, 11:05 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

Автор - Лойер
Дата добавления - 30.03.2016 в 11:05
Лойер Дата: Четверг, 31.03.2016, 15:03 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - Лойер
Дата добавления - 31.03.2016 в 15:03
SLAVICK Дата: Четверг, 31.03.2016, 17:41 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 1962
Репутация: 669 ±
Замечаний: 0% ±

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

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

как то так:
[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(68Kb)


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

Сообщение отредактировал SLAVICK - Четверг, 31.03.2016, 17:55
 
Ответить
Сообщение
обнаружил вот какой косяк..если в "базе" номера в первом столбце будут идти не по возрастанию, то все работает криво

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

как то так:
[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

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

Автор - SLAVICK
Дата добавления - 31.03.2016 в 17:41
Лойер Дата: Вторник, 05.04.2016, 08:47 | Сообщение № 8
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
SLAVICK, спасибо, теперь все грамотно работает.
 
Ответить
СообщениеSLAVICK, спасибо, теперь все грамотно работает.

Автор - Лойер
Дата добавления - 05.04.2016 в 08:47
Hugo Дата: Вторник, 05.04.2016, 08:59 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2671
Репутация: 599 ±
Замечаний: 0% ±

Вместо
[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]
так меньше преобразований и проверок, и заодно от косяков с пробелами подстрахуетесь.
Ну и при проверке тоже аналогично откидываем пробелы, можно использовать временную переменную, чтоб два раза не откидывать.


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069
 
Ответить
СообщениеВместо
[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]
так меньше преобразований и проверок, и заодно от косяков с пробелами подстрахуетесь.
Ну и при проверке тоже аналогично откидываем пробелы, можно использовать временную переменную, чтоб два раза не откидывать.

Автор - Hugo
Дата добавления - 05.04.2016 в 08:59
SLAVICK Дата: Вторник, 05.04.2016, 09:49 | Сообщение № 10
Группа: Модераторы
Ранг: Старожил
Сообщений: 1962
Репутация: 669 ±
Замечаний: 0% ±

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

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

Иногда нужно чтобы искало "четкое соответствие" - тогда trim - нельзя использовать.
Если нужно искать без пробелов - тогда уж лучше пользоваться replace ом - например будет:
"...ул. правды..." и "...ул.правды..." - трим не спасет - а реплейс поможет :D , а еще может быть и "...ул правды..." - тогда мой 2-й режим :)
По поводу записи сразу dic.item(...- оно немного быстрее, но тут уже дело привычки - возьму себе на заметку попробовать - просто конструкции
[vba]
Код
If ... dic.Exists ...
[/vba]
мне проще для восприятия, и в коде сразу можно обрабатывать условия если False.


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
и заодно от косяков с пробелами подстрахуетесь

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

Иногда нужно чтобы искало "четкое соответствие" - тогда trim - нельзя использовать.
Если нужно искать без пробелов - тогда уж лучше пользоваться replace ом - например будет:
"...ул. правды..." и "...ул.правды..." - трим не спасет - а реплейс поможет :D , а еще может быть и "...ул правды..." - тогда мой 2-й режим :)
По поводу записи сразу dic.item(...- оно немного быстрее, но тут уже дело привычки - возьму себе на заметку попробовать - просто конструкции
[vba]
Код
If ... dic.Exists ...
[/vba]
мне проще для восприятия, и в коде сразу можно обрабатывать условия если False.

Автор - SLAVICK
Дата добавления - 05.04.2016 в 09:49
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос - аналог ВПР (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!