Всем привет Подскажите пожалуйста как можно из одного массива сделать другой по условию т.е. есть таблица которая находится в массиве (лист2) и таблица которая тоже находится в массиве (лист1) с условием в столбце 2 (статус) - нужно сформировать новый массив из листа2 при этом чтобы статус равен 1 т.е. итоговый результат находится в таблице (лист результат) который тоже в массиве.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
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
Почему должен уговаривать? В следующий раз ждать не буду - удалю тему вместе с решениями. В назидание. И пусть у смирновых голова болит, а не у модератора. Это всех сердобольных касается