Познавательное

Задание диапазона условий на основе формул с помощью VBA

  

Ниже приведен код усовершенствованного варианта формы для создания отчета. Обратите внимание на метод OKButton_Click, создающий диапазон
условий на основе формул.

Private Sub CancelButton_Click()
Unload Me
End Sub
Private Sub cbSubAll_Click()
'  Выделить всех заказчиков.
For i = 0 To lbCust.ListCount - 1
Me.lbCust.Selected(i)  = True
Next i
End Sub
Private Sub cbSubClear_Click()
'  Отменить выделение заказчиков.
For i = 0 To lbCust.ListCount - 1
Me.lbCust.Selected(i)  = False
Next i
End Sub
Private Sub CommandButtonl_Click()
'  Отменить выделение товаров.
For i = 0 To IbProduct.ListCount - 1
Me.lbProduct.Selected(i)  = False
Next i
End Sub
Private Sub CommandButton2_Click()
'  Выделить все товары.
For i = 0 To IbProduct.ListCount - 1
Me.lbProduct.Selected(i)  = True
Next i
End Sub
Private Sub CommandButton3_Click()
'  Отменить выделение регионов.
For i = 0 To IbRegion.ListCount - 1
Me.IbRegion.Selected(i)  = False
Next i
End Sub
Private Sub CommandButton4_Click()
'  Выделить все регионы.
For i = 0 To IbRegion.ListCount - 1
Me.IbRegion.Selected(i)  = True
Next i
End Sub
Private Sub OKButton_Click()
Dim CRange As Range,   IRange As Range,  ORange As Range
'  Создание сложного условия,  состоящего из нескольких
'  условий,  объединенных с помощью логического И.
NextCCol = 10
NextTCol = 15
For j   = 1 To 3
Select Case j
Case 1
MyControl = "lbCust"
MyColumn - 4
Case 2
MyControl = "lbProduct"
MyColumn = 2
Case 3
MyControl = "IbRegion"
MyColumn = 1
End Select
NextRow = 2
'  Проверка выбора пользователя.
For i = 0 To Me.Controls(MyControl).ListCount - 1
If Me.Controls(MyControl).Selected(i)  = True Then
Cells(NextRow, NextTCol).Value = _
Me.Controls(MyControl).List(i)
NextRow = NextRow + 1
End If
Next i
'  Создание новой формулы условия.
If NextRow > 2 Then
' Использование относительных ссылок на строку R2 обязательно.
' В англоязычной версии Excel:
MyFormula =   11 =NOT (ISNA (MATCH (RC"   & MyColumn &   ",R2C"   & _
NextTCol & 11 :R" & NextRow - 1 & "C" & NextTCol & ", False) )) 11
Cells(2,  NextCCol).FormulaRlCl = MyFormula
MyFormula =   "=HE(ЕНД(ПОИСКПОЗ(RC"  & _
MyColumn & ";R2C" & NextTCol & ":R" & NextRow - 1 & "C" & _
NextTCol & ";Ложь)))"
Cells(2,  NextCCol).FormulaRlClLocal = MyFormula
NextTCol = NextTCol + 1
NextCCol = NextCCol + 1
End If
Next j
Unload Me
'  На рис.   11.15 показано текущее содержимое рабочего листа.
'  Закрыть форму и создать расширенный фильтр с диапазоном
'  условий на основе построенных выше формул.
If NextCCol > 10 Then
Set CRange = Range(Cells(1,   10),  Cells(2, NextCCol - 1))
Set IRange = Range("Al").CurrentRegion
Set ORange = Cells(1, 20)
IRange.AdvancedFiIter xlFilterCopy,  CRange, ORange
' Очистить диапазон условий.
Cells {1,   10) .Resized,   10) . EntireColumn. Clear
End If
'  Вывести сообщение.
MsgBox "Область вставки результата применения фильтра
начинается с ячейки Т1"
End Sub
Private Sub UserForm_Initialize()
Dim IRange As Range
Dim ORange As Range
' Определение размера диапазона исходных данных.
FinalRow = Cells(65536,   1).End(xlUp).Row
NextCol = Cells(1,  255).End(xlToLeft).Column + 2
'  Определение исходного диапазона данных.
Set IRange = Range("Al").Resize(FinalRow, NextCol - 2)
'  Определение целевого диапазона данных.
'  Копирование заголовка столбца D1 в столбец Л.
Range("Dl").Copy Destination:=Cells(1, NextCol)
Set ORange = Cells(1, NextCol)
'  Применение расширенного фильтра для отбора
'  уникальных значений из столбца D.
IRange.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:="",  CopyToRange:=ORange,  Unique:=True
'  Определение размера списка заказчиков.
LastRow = Cells(65536, NextCol).End(xlUp).Row
'  Сортировка списка заказчиков.
Cellsd,  NextCol) .Resize (LastRow,   D.Sort Keyl: =Cells (1,
NextCol), Orderl:=xlAscending, Header:=xlYes
With Me.lbCust
.RowSource = ""
FinalRow = Range("J65536").End(xlUp).Row
For Each cell In 06113(2, NextCol).Resize(LastRow - 1, 1)
.Addltem cell.Value
Next cell
End With
'  Удаление списка заказчиков.
Cells(1,  NextCol).Resize(LastRow,   1).Clear
'  Определение целевого диапазона данных.
'  Копирование заголовка столбца В1 в столбец Л.
Range ("В111) .Copy Destination: =Cells (1, NextCol)
Set ORange = Cells(1, NextCol)
'  Применение расширенного фильтра для отбора
'  уникальных значений из столбца В.
IRange.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=0Range,  Unique:=True
'  Определение размера списка товаров.
LastRow = Cells(65536, NextCol).End(xlUp).Row
'  Сортировка списка товаров.
Cellsd,  NextCol) .Resize (LastRow,   1) .Sort Keyl: =Cells (1, _
NextCol), Orderl:=xlAscending, Header:=xlYes
Wi th Me.lbProduc t
.RowSource = ""
FinalRow = Range("J65536").End(xlUp).Row
For Each cell In Cells(2, NextCol).Resize(LastRow - 1, 1)
.Addltem cell.Value
Next cell
End With
'  Удаление списка товаров.
Cells(1, NextCol).Resize(LastRow,   1).Clear
'  Определение целевого диапазона данных.
'  Копирование заголовка столбца А1 в столбец Л.
Range("Al").Copy Destination:=Cells(1, NextCol)
Set ORange = Cells(1, NextCol)
'  Применение расширенного фильтра для отбора
'  уникальных значений из столбца А.
IRange.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=0Range,  Unique:=True
'  Определение размера списка регионов.
LastRow = Cells(65536, NextCol).End(xlUp)-Row
'  Сортировка списка регионов.
Cellsd,  NextCol) .Resize (LastRow,   D.Sort Keyl: =Cells (1, _
NextCol),  Orderl:=xlAscending,  Header:=xlYes
With Me.IbRegion
.RowSource = ""
FinalRow = Range("J65536").End(xlUp).Row
For Each cell In 06113(2, NextCol).Resize(LastRow - 1, 1)
.Addltem cell.Value
Next cell
End With
Удаление списка регионов.
Cells(1, NextCol).Resize(LastRow,   1).Clear
End Sub


На рис. 11.15 показано содержимое рабочего листа перед выполнением метода AdvancedFilter. Макрос помещает выбранные пользователем данные (заказчиков, товары и регионы) в столбцы О, Р и Q, а затем определяет диапазон условий как J1: L2. Формула в ячейке J2 проверяет, входит ли значение в ячейке $D2 в список заказчиков в столбце О. Формулы в ячейках К2 и L2 осуществляют аналогичную проверку для ячеек $В2, $А2 и столбцов Р, Q, соответственно.
Внимание
В справочной системе Excel VBA сказано, что для отбора данных без применения условия достаточно не задать диапазон условий. В Excel 2003 это не так — если вы не определите диапазон условий, метод AdvancedFilter будет использовать значение CriteriaRange, заданное при предыдущем вызове этого метода. Чтобы избежать недоразумений, очистите значение CriteriaRange, например, укажите CriteriaRange="" при вызове метода AdvancedFilter.

Задание диапазона условий на основе формул с помощью VBA

Рис. 11.15. Содержимое рабочего листа перед применением расширенного фильтра


Использование условия на основе формулы при решении экономических задач
Следует признать, что задание диапазона условий расширенного фильтра с помощью формулы — эффективное, но редко используемое решение. В свете этого необходимо упомянуть об одном его весьма интересном применении. Ниже приведена формула, позволяющая отобрать строки, значение в столбце А которых больше среднего значения по этому столбцу на всем диапазоне исходных данных:
=$А2>СРЗНАЧ($А$2:$А$60000)
(В англоязычной версии Excel следует использовать формулу =$А2>AVERAGE ($А$2:$А$60000).)
 


Посетители, находящиеся в группе Гости, не могут оставлять комментарии к данной публикации.