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

Вход

Регистрация

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

 

= Мир MS Excel/Впр для ленивых, или улучшенный ВПР2 - Мир MS Excel

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

2007,2010,2013,2016
Всем привет. Попросили меня поделится макросом ВПРа, которым я пользуюсь.
Вот решил и сюда кинуть упрощенную версию - может кому сгодится.
В общем в чем отличие от обычного ВПРа:
Главное это возможность поиска не по первому столбцу.
и еще возможность выбора сразу нескольких столбцов для вывода информации(можно конечно и в ВПРе написать Столбец("A1")... но я же ленивый :) )

От аналогичного готового решения отличается скоростью и возможностью выбора сразу нескольких столбцов.
Ну и возможность выбора нужных столбцов мышей :D .

Можно использовать как формулу массива, но я чаще использую макросом - для большого объема данных(свыше 50тыс +) скорость будет значительно выше чем использование обычного ВПРа.

В общем вот функция:
[vba]
Код
Function ВПР_1(Диапазон_для_поиска_диапазон As Range, Диапазон_Справочника_диапазон As Range, _
Столбец_информации As Range, Столбцы_вывода_диапазон As Range) As Variant
Dim Диапазон_для_поиска()
Dim Диапазон_Справочника()
Dim Addr$
Dim wb As Workbook
Dim SLOVOPOLN As String
Dim dic As New Scripting.Dictionary
Dim СправочникСтолцов As New Scripting.Dictionary
Dim c(), cel As Range, STOLB%, Столбцы_вывода, stolbStart%, i#, SLOVO$
dic.CompareMode = TextCompare

Диапазон_для_поиска = Диапазон_для_поиска_диапазон.Value
Диапазон_Справочника = Диапазон_Справочника_диапазон.Value

'    Получаем список уникальных столбцов
    With СправочникСтолцов
        For Each cel In Столбцы_вывода_диапазон
            STOLB = cel.Column - Диапазон_Справочника_диапазон.Column + 1
            If Not .Exists(STOLB) Then .Add STOLB, STOLB
        Next
    Столбцы_вывода = .Items
    End With
    
    stolbStart = Столбец_информации.Column - Диапазон_Справочника_диапазон.Column + 1
    ReDim c(1 To UBound(Диапазон_для_поиска), 1 To UBound(Столбцы_вывода) + 1)
    With dic
        For i = 1 To UBound(Диапазон_Справочника)
        If Not .Exists(Диапазон_Справочника(i, stolbStart)) Then .Add Диапазон_Справочника(i, stolbStart), i
        Next
        
        For i = 1 To UBound(Диапазон_для_поиска)
        SLOVO = CStr(Диапазон_для_поиска(i, 1))
        If Len(SLOVO) Then
            If .Exists(SLOVO) Then
                For STOLB = 0 To UBound(Столбцы_вывода)
                c(i, STOLB + 1) = Диапазон_Справочника(.Item(SLOVO), Столбцы_вывода(STOLB))
                Next
            End If
        End If
        Next
    End With
        ВПР_1 = c
End Function
[/vba]
И простенький макрос-тест для ее пользования:
[vba]
Код
Sub ВПР_test()
Dim Диапазон_для_поиска_диапазон As Range, Диапазон_Справочника_диапазон As Range, _
Столбец_информации As Range, Столбцы_вывода_диапазон As Range, Столбец_вывода_Информации_диапазон As Range
Dim массив
Set Диапазон_для_поиска_диапазон = Application.InputBox("Диапазон_для_поиска_диапазон", Default:=[j2:j5].AddressLocal, Type:=8)
Set Столбец_вывода_Информации_диапазон = Application.InputBox("Столбец_вывода_Информации_диапазон", Default:=Диапазон_для_поиска_диапазон.Offset(, 1).AddressLocal, Type:=8)
'можно выделить несколько ячеек сразу - для этого нажать ctrl  и выбрать нужные столбцы мышью

Set Диапазон_Справочника_диапазон = Application.InputBox("Диапазон_Справочника_диапазон", Default:=[a1:e100].AddressLocal, Type:=8)
Диапазон_Справочника_диапазон.Parent.Parent.Activate: Диапазон_Справочника_диапазон.Parent.Activate

Set Столбец_информации = Application.InputBox("Столбец_информации", Default:=[c3].AddressLocal, Type:=8)
Set Столбцы_вывода_диапазон = Application.InputBox("Столбцы_вывода_диапазон", Default:=Range("$A$7:A10,$C$7,$E$7").AddressLocal, Type:=8)

массив = ВПР_1(Диапазон_для_поиска_диапазон, Диапазон_Справочника_диапазон, Столбец_информации, Столбцы_вывода_диапазон)

Столбец_вывода_Информации_диапазон.Parent.Parent.Activate: Столбец_вывода_Информации_диапазон.Parent.Activate
Столбец_вывода_Информации_диапазон.Cells(1, 1).Resize(UBound(массив), UBound(массив, 2)) = массив

End Sub
[/vba]
В приложенном файле есть способ применения ее в виде формулы массива, и макрос - с подсказками - нажать на кнопку. :D .
Всем успехов .
К сообщению приложен файл: 7730281-2-2-.xlsm(26Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
СообщениеВсем привет. Попросили меня поделится макросом ВПРа, которым я пользуюсь.
Вот решил и сюда кинуть упрощенную версию - может кому сгодится.
В общем в чем отличие от обычного ВПРа:
Главное это возможность поиска не по первому столбцу.
и еще возможность выбора сразу нескольких столбцов для вывода информации(можно конечно и в ВПРе написать Столбец("A1")... но я же ленивый :) )

От аналогичного готового решения отличается скоростью и возможностью выбора сразу нескольких столбцов.
Ну и возможность выбора нужных столбцов мышей :D .

Можно использовать как формулу массива, но я чаще использую макросом - для большого объема данных(свыше 50тыс +) скорость будет значительно выше чем использование обычного ВПРа.

В общем вот функция:
[vba]
Код
Function ВПР_1(Диапазон_для_поиска_диапазон As Range, Диапазон_Справочника_диапазон As Range, _
Столбец_информации As Range, Столбцы_вывода_диапазон As Range) As Variant
Dim Диапазон_для_поиска()
Dim Диапазон_Справочника()
Dim Addr$
Dim wb As Workbook
Dim SLOVOPOLN As String
Dim dic As New Scripting.Dictionary
Dim СправочникСтолцов As New Scripting.Dictionary
Dim c(), cel As Range, STOLB%, Столбцы_вывода, stolbStart%, i#, SLOVO$
dic.CompareMode = TextCompare

Диапазон_для_поиска = Диапазон_для_поиска_диапазон.Value
Диапазон_Справочника = Диапазон_Справочника_диапазон.Value

'    Получаем список уникальных столбцов
    With СправочникСтолцов
        For Each cel In Столбцы_вывода_диапазон
            STOLB = cel.Column - Диапазон_Справочника_диапазон.Column + 1
            If Not .Exists(STOLB) Then .Add STOLB, STOLB
        Next
    Столбцы_вывода = .Items
    End With
    
    stolbStart = Столбец_информации.Column - Диапазон_Справочника_диапазон.Column + 1
    ReDim c(1 To UBound(Диапазон_для_поиска), 1 To UBound(Столбцы_вывода) + 1)
    With dic
        For i = 1 To UBound(Диапазон_Справочника)
        If Not .Exists(Диапазон_Справочника(i, stolbStart)) Then .Add Диапазон_Справочника(i, stolbStart), i
        Next
        
        For i = 1 To UBound(Диапазон_для_поиска)
        SLOVO = CStr(Диапазон_для_поиска(i, 1))
        If Len(SLOVO) Then
            If .Exists(SLOVO) Then
                For STOLB = 0 To UBound(Столбцы_вывода)
                c(i, STOLB + 1) = Диапазон_Справочника(.Item(SLOVO), Столбцы_вывода(STOLB))
                Next
            End If
        End If
        Next
    End With
        ВПР_1 = c
End Function
[/vba]
И простенький макрос-тест для ее пользования:
[vba]
Код
Sub ВПР_test()
Dim Диапазон_для_поиска_диапазон As Range, Диапазон_Справочника_диапазон As Range, _
Столбец_информации As Range, Столбцы_вывода_диапазон As Range, Столбец_вывода_Информации_диапазон As Range
Dim массив
Set Диапазон_для_поиска_диапазон = Application.InputBox("Диапазон_для_поиска_диапазон", Default:=[j2:j5].AddressLocal, Type:=8)
Set Столбец_вывода_Информации_диапазон = Application.InputBox("Столбец_вывода_Информации_диапазон", Default:=Диапазон_для_поиска_диапазон.Offset(, 1).AddressLocal, Type:=8)
'можно выделить несколько ячеек сразу - для этого нажать ctrl  и выбрать нужные столбцы мышью

Set Диапазон_Справочника_диапазон = Application.InputBox("Диапазон_Справочника_диапазон", Default:=[a1:e100].AddressLocal, Type:=8)
Диапазон_Справочника_диапазон.Parent.Parent.Activate: Диапазон_Справочника_диапазон.Parent.Activate

Set Столбец_информации = Application.InputBox("Столбец_информации", Default:=[c3].AddressLocal, Type:=8)
Set Столбцы_вывода_диапазон = Application.InputBox("Столбцы_вывода_диапазон", Default:=Range("$A$7:A10,$C$7,$E$7").AddressLocal, Type:=8)

массив = ВПР_1(Диапазон_для_поиска_диапазон, Диапазон_Справочника_диапазон, Столбец_информации, Столбцы_вывода_диапазон)

Столбец_вывода_Информации_диапазон.Parent.Parent.Activate: Столбец_вывода_Информации_диапазон.Parent.Activate
Столбец_вывода_Информации_диапазон.Cells(1, 1).Resize(UBound(массив), UBound(массив, 2)) = массив

End Sub
[/vba]
В приложенном файле есть способ применения ее в виде формулы массива, и макрос - с подсказками - нажать на кнопку. :D .
Всем успехов .

Автор - SLAVICK
Дата добавления - 13.09.2016 в 18:06
Мир MS Excel » Вопросы и решения » Готовые решения » Впр для ленивых, или улучшенный ВПР2 (Excel)
Страница 1 из 11
Поиск:

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