Страницы: 1
RSS
Сбор наименований заказчиков по номеру заказа в одну ячейку, многократный ВПР
 
Доброго времени суток, уважаемые форумчане! Понимаю что тема не новая, но ответа не нашел...

Мне нужно реализовать многократный впр формулой, и результат вывести через разделитель ";". При использовании функции VLOOKUPCOUPLE получается слишком длительное заполнение...

Подскажите, пожалуйста, как это возможно реализовать?  
 
Код
База!C2     =ЕСЛИ(СЧЁТЕСЛИМН(A3:$A$1048576;Таблица1[@Заказ];B3:$B$1048576;Таблица1[@Заказчик])=0;Таблица1[@Заказчик]&", ";"")&ЕСЛИОШИБКА(ВПР(Таблица1[@Заказ];A3:C$1048576;3;0);"")
Свод!B3     =ВПР([@Заказ];База!A:C;3;0)

Изменено: МатросНаЗебре - 19.04.2021 12:06:15
 
МатросНаЗебре

Спасибо! Вроди все как нужно. Сейчас протестирую на основном файле.

А как можно скорректировать что бы не выводилась запятая если значение одно (Заказчик2,), и после последнего значения (Заказчик2,Заказчик3,)

Есть еще варианты?)  
Изменено: BRP - 19.04.2021 12:24:21
 
Код
=ПСТР(ВПР([@Заказ];База!A:C;3;0);1;ДЛСТР(ВПР([@Заказ];База!A:C;3;0))-2)
=ЕСЛИОШИБКА(ПСТР(ВПР([@Заказ];База!A:C;3;0);1;ДЛСТР(ВПР([@Заказ];База!A:C;3;0))-2);"") 'Для обработки ошибки #Н/Д
Изменено: МатросНаЗебре - 19.04.2021 12:33:34
 
BRP,
есть крутая пользовательская функция "Concat" господина ZVI
Возможно, кто-то скинет ссылочку  :)  
Изменено: evgeniygeo - 19.04.2021 12:49:14
 
МатросНаЗебре
Огромное спасибо!  
 
evgeniygeo

Спасибо! Попробую и этот вариант.  
 
как вариант названия темы:
"сбор наименований заказчиков по номеру заказа в одну ячейку"
 
МатросНаЗебре

При малом к-ве строк все работает. Но когда тестирую на файле с 35 тыс. строк то мне пишет не достаточно памяти и выкидывает из excel...
 
Я моя работает! :)
А что значит "получается слишком длительное заполнение"? Может юзаете что-то из первых версий?
 
Hugo

"получается слишком длительное заполнение" - для того что бы обновилась информация уходит более 30 мин...

Код
Function VLOOKUPCOUPLE(Table As Variant, _

                        SearchColumnNum As Integer, _

                        SearchValue As Variant, _

                        RezultColumnNum As Integer, _

                        Separator_ As String, _

                        Optional BezPovtorov As Boolean = True)

                          

'Table - таблица, где ищем

'SearchColumnNum - столбец, где ищем

'SearchValue - данные, которые ищем

'RezultColumnNum - столбец, откуда берём результат

'Separator_ - разделитель, желательно вводить с пробелом в конце

'BezPovtorov - если поставить 0, то будут выведены все повторяющиеся совпадения

  

    Dim i As Long, tmp As String, vlk

  

    If TypeName(Table) = "Range" Then Table = Intersect(Table.Parent.UsedRange, Table).Value

    If BezPovtorov Then

        With CreateObject("Scripting.Dictionary")

            For i = 1 To UBound(Table)

                If Table(i, SearchColumnNum) = SearchValue Then

                    tmp = Table(i, RezultColumnNum)

                    If tmp <> "" Then

                        If Not .Exists(tmp) Then

                            .Add tmp, 0&

                            vlk = vlk & Separator_ & Table(i, RezultColumnNum)

                        End If

                    End If

                End If

            Next i

        End With

    Else

        For i = 1 To UBound(Table)

            If Table(i, SearchColumnNum) = SearchValue Then

                vlk = vlk & Separator_ & Table(i, RezultColumnNum)

            End If

        Next i

    End If

    If vlk > 0 Then vlk = Mid(vlk, Len(Separator_) + 1) Else vlk = ""

    VLOOKUPCOUPLE = vlk

End Function
Изменено: BRP - 19.04.2021 14:08:02
 
https://www.excel-vba.ru/multex/vpr2-poisk-po-chetyrem-kriteriyam-vyvod-vsex-sovpadenij

Как тест.... на 35 тыс. строк.

здесь нужно немного переделать (макрос)
https://coderoad.ru/23869063
Изменено: Marat Ta - 19.04.2021 14:12:25
 
Цитата
BRP написал:
уходит более 30 мин
- данные в одном файле на разных листах, как в примере? Макросы на событие какие-то есть?
 
Hugo,

Да, данные в одном файле на разных листах. Макросов на событие нет.
 
Для большого количества строк подойдёт такой макрос.
Код
Sub ЗаказЗаказчик()
    With ActiveSheet
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(arr, 1)
        If Not dic.exists(CStr(arr(y, 1))) Then
            Set dic.Item(CStr(arr(y, 1))) = CreateObject("Scripting.Dictionary")
        End If
        dic.Item(CStr(arr(y, 1))).Item(CStr(arr(y, 2))) = 0
    Next
    If dic.Count > 0 Then
        ReDim arr(1 To dic.Count, 1 To 2)
        For y = 1 To UBound(arr, 1)
            arr(y, 1) = dic.Keys()(y - 1)
            arr(y, 2) = Join(dic.Items()(y - 1).Keys(), ", ")
        Next
    End If
    Workbooks.Add(1).Sheets(1).Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
 
Спасибо! Но не совсем то. Макрос создает отдельный файл, не совсем то что мне нужно.
 
Ну можно и мою формулу подпилить под конкретную задачу - чтоб не брать миллион раз миллион строк в миллион массивов, а обойтись одним исходным массивом.
А если написать и использовать как формулу массива - то и обойтись одним массивом и одним словарём на весь лист.
 
Для вывода на лист Свод, поправьте строку, выводящую массив:
Код
Sheets("Свод").Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
 
МатросНаЗебре,
Круто, меньше минуты готовит данные...

Прошу прощения за наглость, а  можно его переделать что бы я его запускал не только из активного листа (то есть запускаю с любого листа а обрабатывается только лист База ),  Данные брать не из 2 столбца а из 60?
 
Так работает не с активного листа. Данные берёт из столбца 60.
Код
Sub ЗаказчикЗаказчика()
    With Sheets("База")
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        If y = 1 Then y = 2
        Dim arr As Variant: arr = .Range(.Cells(1, 1), .Cells(y, 1))
        Dim brr As Variant: brr = .Range(.Cells(1, 60), .Cells(y, 60))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(arr, 1)
        If Not dic.exists(CStr(arr(y, 1))) Then
            Set dic.Item(CStr(arr(y, 1))) = CreateObject("Scripting.Dictionary")
        End If
        dic.Item(CStr(arr(y, 1))).Item(CStr(brr(y, 1))) = 0
    Next
    If dic.Count > 0 Then
        ReDim arr(1 To dic.Count, 1 To 2)
        For y = 1 To UBound(arr, 1)
            arr(y, 1) = dic.Keys()(y - 1)
            arr(y, 2) = Join(dic.Items()(y - 1).Keys(), ", ")
        Next
    End If
    With Sheets("Свод")
        .Cells.Clear
        .Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub
 
МатросНаЗебре,

Написал в личку.
Страницы: 1
Наверх