Страницы: 1
RSS
Исзлечь все значения из второго столбца в таблице, которые в первом имеют определенное значение
 
Всем здравствуйте, подскажите, пожалуйста, как можно извлечь данные из таблицы на 2 листе на 1 лист, по такому условию: если в номер склада в столбце B = 1, то на лист1 в столбец B извлекутся все значения столба С (id товара) друг за дружкой.
Нашёл только формулу массива, можно ли это сделать обычной немассивной формулой или быстрым кодом?
 
Костя Легирев,  лист 1 пустой изначально?в В2 и протянуть  вниз и вправо
Код
=ЕСЛИОШИБКА(ИНДЕКС(Лист2!$C$1:$C$7;АГРЕГАТ(15;6;СТРОКА(Лист2!$C$1:$C$7)/(Лист2!$B$1:$B$7=СТОЛБЕЦ()-1);СТРОКА()-1));"")
Изменено: Mershik - 27.12.2021 14:59:21
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, нет, там тоже есть табличка-итоговый результат c B1:E3.
 
Цитата
Костя Легирев написал:
можно ли это сделать обычной немассивной формулой
Можно с доп.столбцами. А чем массивная не устраивает?
Цитата
Костя Легирев написал:
быстрым кодом
Быстрым на сколько секунд? Таблица насколько большая?
 
Mershik, спасибо Вам огромнейшее, это то что нужно было.
 
Вариант кодом. Выделите Лист2!B2:C7. Запустите макрос.
Код
Sub SoMustBe()
    Dim arr As Variant
    Dim brr As Variant
    arr = Selection.Areas(1).Columns(1).Resize(, 2)
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    Dim m As Long
    For y = 1 To UBound(arr, 1)
        If dic.Exists(arr(y, 1)) Then
            brr = dic.Item(arr(y, 1))
            ReDim Preserve brr(0 To UBound(brr) + 1)
        Else
            ReDim brr(0 To 0)
        End If
        If m < UBound(brr) Then m = UBound(brr)
        brr(UBound(brr)) = arr(y, 2)
        dic.Item(arr(y, 1)) = brr
        Erase brr
    Next
    
    If dic.Count > 0 Then
        ReDim arr(1 To m + 2, 1 To dic.Count)
        Dim x As Integer
        For x = 1 To dic.Count
            arr(1, x) = dic.Keys()(x - 1)
            brr = dic.Items()(x - 1)
            For y = 0 To UBound(brr)
                arr(y + 2, x) = brr(y)
            Next
        Next
        
        With Workbooks.Add(1)
            With .Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Value = arr
            End With
            .Saved = True
        End With
    End If
End Sub
 
Еще вариант макросом. Выгрузка на 1лист  ячейка В2
Код
Sub enstaralпава()
    Dim arr1, Tp1, Tp2, i&, j&, k&, dic1, dic2, dic3
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set dic3 = CreateObject("Scripting.Dictionary")
    arr1 = Worksheets(2).Cells(2).CurrentRegion
        For i = 2 To UBound(arr1)
Tp1 = dic1(arr1(i, 1)): Tp1 = dic2(arr1(i, 2)): dic3(arr1(i, 1) & arr1(i, 2)) = arr1(i, 2)
        Next
Tp1 = dic1.Keys: Tp2 = dic2.Keys: ReDim arr1(UBound(Tp2), UBound(Tp1))
    Set dic1 = Nothing: Set dic2 = Nothing
For i = 0 To UBound(Tp1): k = 0: For j = 0 To UBound(Tp2)
    If dic3.exists(Tp1(i) & Tp2(j)) Then arr1(k, i) = dic3(Tp1(i) & Tp2(j)): k = k + 1
Next: Next
Worksheets(1).Range("B2").Resize(UBound(arr1) + 1, UBound(arr1, 2) + 1) = arr1
End Sub

Вероятно надо, чтобы все значения 2 столбца попали в результат а в коде выше  во 2 словаре заполняются ключи, поэтому повторяющие значения во 2 столбце не попадут в результат. Надо заменить  8 и 10 строки на

Код
Tp1 = dic1(arr1(i, 1)): dic2(dic2.Count) = arr1(i, 2): dic3(arr1(i, 1) & arr1(i, 2)) = arr1(i, 2)
Tp1 = dic1.keys: Tp2 = dic2.items: ReDim arr1(UBound(Tp2), UBound(Tp1))

Изменено: Евгений Смирнов - 28.12.2021 11:51:47
 
Можно ещё PQ
Код
let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    Склад = Table.AddColumn(Источник, "склад1", each "Склад " &Text.From([склад])),
    Груп = Table.Group(Склад,"склад1",{"tmp",(x)=>x[id товара]}),
    Груп1 = Table.FromColumns(Груп[tmp],Груп[склад1])
in
    Груп1


и ещё вариант макросом
Код
Sub Макрос1()
Dim Tp1, Tp2, i&, j, n&, m&, dic1
Set dic1 = CreateObject("Scripting.Dictionary")
n = 0
arr1 = Worksheets("Лист2").Range("B2:C" & Worksheets("Лист2").Cells(Rows.Count, 2).End(xlUp).Row)
    For i = 1 To UBound(arr1)
        If Not dic1.Exists(arr1(i, 1) & " склад") Then
            dic1.Add arr1(i, 1) & " склад", arr1(i, 2)
        Else
            dic1.Item(arr1(i, 1) & " склад") = dic1.Item(arr1(i, 1) & " склад") & ";" & arr1(i, 2)
        End If
        If n < UBound(Split(dic1.Item(arr1(i, 1) & " склад"), ";")) Then n = UBound(Split(dic1.Item(arr1(i, 1) & " склад"), ";"))
    Next
ReDim Tp1(0 To n + 1, 1 To dic1.Count)
n = 1
For Each j In dic1
    Tp2 = Split(dic1.Item(j), ";")
    Tp1(0, n) = j
    For m = 0 To UBound(Tp2)
        Tp1(m + 1, n) = Tp2(m)
    Next
    n = n + 1
Next
Worksheets("Лист1").Range("B1").Resize(UBound(Tp1) + 1, UBound(Tp1, 2)) = Tp1
End Sub
Изменено: Msi2102 - 28.12.2021 13:10:50
Страницы: 1
Наверх