Всем привет! Такая тема уже была, но задача несколько иная... Необходимо удалить максимальное и минимальное значения в столбце, в каждом диапазоне между определенными ячейками (или строками), содержащими слово Март. Заранее благодарен.
Всем привет! Такая тема уже была, но задача несколько иная... Необходимо удалить максимальное и минимальное значения в столбце, в каждом диапазоне между определенными ячейками (или строками), содержащими слово Март. Заранее благодарен.Russt
Макрос не анализирует столбец "C", а разбивает столбец "D" на части по пустым ячейкам.
[vba]
Код
Sub Удалить_Min_Max()
Dim rng As Range, ar As Range, arr(), i As Long Dim min As Double, max As Double
Application.ScreenUpdating = False Set rng = Range("D2:D" & Rows.count).SpecialCells(xlCellTypeConstants) For Each ar In rng.Areas min = WorksheetFunction.min(ar) max = WorksheetFunction.max(ar) If ar.Cells.count = 1 Then ar.Value = Empty Else arr() = ar.Value For i = 1 To UBound(arr) If arr(i, 1) = min Then arr(i, 1) = Empty ElseIf arr(i, 1) = max Then arr(i, 1) = Empty End If Next i ar.Value = arr() End If Next ar MsgBox "Готово!", vbInformation Application.ScreenUpdating = True
End Sub
[/vba]
Этот макрос анализирует столбец "C". Макрос не смотрит названия месяцев, а разбивает столбец "C" на части по непустым ячейкам.
[vba]
Код
Sub Удалить_Min_Max()
Dim rng As Range, ar As Range Dim min As Double, max As Double Dim arr(), lr As Long, i As Long
Application.ScreenUpdating = False lr = Cells(Rows.count, "D").End(xlUp).row Set rng = Range("C2:C" & lr).SpecialCells(xlCellTypeBlanks) For Each ar In rng.Areas Set ar = ar.Offset(, 1) min = WorksheetFunction.min(ar) max = WorksheetFunction.max(ar) If ar.Cells.count = 1 Then ar.Value = Empty Else arr() = ar.Value For i = 1 To UBound(arr) If arr(i, 1) = min Then arr(i, 1) = Empty ElseIf arr(i, 1) = max Then arr(i, 1) = Empty End If Next i ar.Value = arr() End If Next ar MsgBox "Готово!", vbInformation Application.ScreenUpdating = True
End Sub
[/vba]
Макрос не анализирует столбец "C", а разбивает столбец "D" на части по пустым ячейкам.
[vba]
Код
Sub Удалить_Min_Max()
Dim rng As Range, ar As Range, arr(), i As Long Dim min As Double, max As Double
Application.ScreenUpdating = False Set rng = Range("D2:D" & Rows.count).SpecialCells(xlCellTypeConstants) For Each ar In rng.Areas min = WorksheetFunction.min(ar) max = WorksheetFunction.max(ar) If ar.Cells.count = 1 Then ar.Value = Empty Else arr() = ar.Value For i = 1 To UBound(arr) If arr(i, 1) = min Then arr(i, 1) = Empty ElseIf arr(i, 1) = max Then arr(i, 1) = Empty End If Next i ar.Value = arr() End If Next ar MsgBox "Готово!", vbInformation Application.ScreenUpdating = True
End Sub
[/vba]
Этот макрос анализирует столбец "C". Макрос не смотрит названия месяцев, а разбивает столбец "C" на части по непустым ячейкам.
[vba]
Код
Sub Удалить_Min_Max()
Dim rng As Range, ar As Range Dim min As Double, max As Double Dim arr(), lr As Long, i As Long
Application.ScreenUpdating = False lr = Cells(Rows.count, "D").End(xlUp).row Set rng = Range("C2:C" & lr).SpecialCells(xlCellTypeBlanks) For Each ar In rng.Areas Set ar = ar.Offset(, 1) min = WorksheetFunction.min(ar) max = WorksheetFunction.max(ar) If ar.Cells.count = 1 Then ar.Value = Empty Else arr() = ar.Value For i = 1 To UBound(arr) If arr(i, 1) = min Then arr(i, 1) = Empty ElseIf arr(i, 1) = max Then arr(i, 1) = Empty End If Next i ar.Value = arr() End If Next ar MsgBox "Готово!", vbInformation Application.ScreenUpdating = True