Страницы: 1
RSS
Фильтр таблиц с разных листов на третий по условию
 
Всем привет
Подскажите пожалуйста как можно из одного массива сделать другой по условию т.е. есть таблица которая находится в массиве (лист2) и таблица которая тоже находится в массиве (лист1) с условием в столбце 2 (статус) - нужно сформировать новый массив из листа2 при этом чтобы статус равен 1 т.е. итоговый результат находится в таблице (лист результат) который тоже в массиве.
Изменено: vikttur - 25.11.2021 13:56:42
 
Код
=ФИЛЬТР(Лист2!A2:C10;Лист1!B2:B10=1)
 
Вам - в правила форума.
Предложите название темы. Заменят модераторы
 
PQ вам в помощь
Тема: Объединение двух таблиц по условию
Изменено: Msi2102 - 25.11.2021 13:54:14
 
PMO87, здравствуйте
PQ. 2 запроса + Объединение
Цитата
P.S.: vikttur: Предложите название темы
кто первый решение дал (Евгений Смирнов), тот пусть и думает  :)
Изменено: Jack Famous - 25.11.2021 12:04:15
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Решение в файле
 
Код
Option Explicit

Sub ФильтрТаблиц()
    Dim ar1 As Variant
    ar1 = Sheets("Лист1").Range("A1:B10")
    
    Dim ar2 As Variant
    ar2 = Sheets("Лист2").Range("A1:C10")
    
    Dim dic As Object
    Set dic = GetDic(ar1)
    Erase ar1
    
    Dim arr As Variant
    arr = GetArrResult(dic, ar2)
    
    PrintArr arr
End Sub

Sub PrintArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
            .Columns(1).NumberFormat = "@"
            .Value = arr
        End With
        .Saved = True
    End With
End Sub

Function GetArrResult(dic, arr) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    Dim y As Long
    Dim u As Long
    Dim x As Integer
    For x = 1 To UBound(arr, 2)
        brr(1, x) = arr(1, x)
    Next
    u = 1
    For y = 2 To UBound(arr, 1)
        If dic.Exists(arr(y, 1)) Then
            u = u + 1
            For x = 1 To UBound(arr, 2)
                brr(u, x) = arr(y, x)
            Next
        End If
    Next
    Dim crr As Variant
    ReDim crr(1 To u, 1 To UBound(brr, 2))
    For y = 1 To UBound(crr, 1)
        For x = 1 To UBound(crr, 2)
            crr(y, x) = brr(y, x)
        Next
    Next
    GetArrResult = crr
End Function

Function GetDic(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 2 To UBound(arr, 1)
        If arr(y, 2) Then dic.Item(arr(y, 1)) = 0
    Next
    Set GetDic = dic
End Function
 
Код
=ИНДЕКС(Лист2!A1:C10;ФИЛЬТР.XML("<j><i>"&ПОДСТАВИТЬ(ОБЪЕДИНИТЬ(СИМВОЛ(1);1;ЕСЛИ((СТРОКА(Лист1!B1:B10)*(Лист1!B1:B10=1))=0;"";СТРОКА(Лист1!B1:B10)*(Лист1!B1:B10=1)));СИМВОЛ(1);"</i><i>")&"</i></j>";"//i");{1;2;3})
 
Jack Famous Я уже не могу думать. Голова болит. Такой большой макрос пришлось написать Устал
 
Фильтр таблиц с разных листов на третий по условию
 
Почему должен уговаривать?
В следующий раз ждать не буду - удалю тему вместе с решениями. В назидание. И пусть у смирновых голова болит, а не у модератора. Это всех сердобольных касается
Страницы: 1
Наверх