Формирование новых таблиц для каждой строки из одной таблицы по критерию - VB
Формулировка задачи:
Здравствуйте! Задача в следующем: в Excel имеется одна таблица, в которой есть столбцы двух уровней - это различные варианты и подварианты. В первом столбце номер элемента (ID), значения каждого элемента указываются в строках таблицы. Необходимо из этой таблицы для каждого элемента сформировать новую таблицу с одной строкой - элементом и столбцами вариантами и подвариантами, в которых значения отобраны по критерию (>220 например).
Пример в приложенном файле.
Может эту задачу можно решить и не используя VBA, буду рад любой помощи
Решение задачи: «Формирование новых таблиц для каждой строки из одной таблицы по критерию»
textual
Листинг программы
Option Explicit
Sub Copy_Table_if()
Dim RSy%, REy%, RSx%, REx% 'Read
Dim WSy%, WCy%, WSx%, WCx% 'Write
Dim X%, Y% 'cycle
Dim Request$, FirstTime As Boolean
'определение границ таблицы (привязка к начальной ячейке B2)
With [B2]
RSy = .Row + 1
REy = .End(xlDown).Row 'Last Row
RSx = .Column + 1 'Column "C"
REx = .End(xlToRight).Column 'Last Column
End With
Request = Range("Criteria") 'Условие в именованной ячейке (Ctrl+F3)
With Range("Result") 'Результат записывать, начиная с именованной ячейки "Result"
WSy = .Row + 1 'Start
WCy = WSy 'Current
WSx = .Column + 1 'Start
WCx = WSx 'Current
End With
For Y = RSy To REy
For X = RSx To REx
If Evaluate(Cells(Y, X).Value & Request) Then
If Not FirstTime Then 'первое значение нашли - создаем таблицу
FirstTime = True
Cells(WCy, WCx).Offset(-1, -1).Value = "ID"
Cells(WCy, WCx).Offset(0, -1).Value = Cells(Y, RSx - 1).Value
End If
Cells(WCy, WCx).Offset(-2, 0).Value = Cells(RSy, X).Offset(-2, 0).Value
Cells(WCy, WCx).Offset(-1, 0).Value = Cells(RSy, X).Offset(-1, 0).Value
Cells(WCy, WCx).Value = Cells(Y, X).Value
WCx = WCx + 1
End If
Next X
'Если были совпадения, делаем промежуток между таблицами результатов
If FirstTime Then FirstTime = False: WCx = WSx: WCy = WCy + 4
Next Y
End Sub