Согласен, название статьи звучит страшно и не совсем понятно. Поэтому явно надо разъяснить поподробнее. Начну с предыстории. На одном форуме форумчанин задал вопрос - "Как инвертировать Selection?"(к слову ник форумчанина - Alex_ST). Т.е. если у Вас на листе выделена ячейка А1, то после работы кода будут выделены все ячейки на листе, кроме этой ячейки. Были предложены варианты, но...Каждый из них имел недостаток: либо для корректной работы требовалось создавать новую книгу или лист, либо не со всеми условиями работал корректно(например, выделение несмежных диапазонов), либо работал так долго, что можно было кофе сварить и выпить пока он работал. И вот на днях выдались пара свободных минут и решил я "добить" ту тему и создать-таки код, который будет работать без создания лишних листов и книг и довольно быстро. Сразу скажу, что довольно быстро понятие относительное. Все зависит от того, где и как выделен диапазон. Если изначально диапазон выделен как один неразрывный или как несколько несвязанных, но расположенных рядом друг с другом, то код отработает так же почти мгновенно. А вот если выделенная область расположена в конце листа(для Excel 2003 - 65536, Excel 2007 - 1048576) и в начале(первые строки и столбцы), то код может работать довольно долго. Но что-то я сомневаюсь, что многие будут выделять одновременно последнюю и первую ячейку на листе.
Option Explicit Dim alArrBegRows(), alArrEndRows(), alArrBegCols(), alArrEndCols() Dim lMinRow As Long, lMaxRow As Long, lMinCol As Long, lMaxCol As Long Sub Invert_Selection() Dim rArea As Range, rInvertRange As Range, rTmpRng As Range, rRng As Range Dim lr As Long, lc As Long, li As Long Dim lEndRow As Long, lEndCol As Long Dim bEqualRows As Boolean, bEqualCols As Boolean If TypeName(Selection) <> "Range" Then Exit Sub For Each rArea In Selection.Areas ReDim Preserve alArrBegRows(li), alArrEndRows(li), alArrBegCols(li), alArrEndCols(li) alArrBegRows(li) = rArea.Row: alArrEndRows(li) = rArea.Row + rArea.Rows.Count - 1 alArrBegCols(li) = rArea.Column: alArrEndCols(li) = rArea.Column + rArea.Columns.Count - 1 li = li + 1 Next rArea lMinRow = alArrBegRows(0): lMaxRow = 0: lMinCol = alArrBegCols(0): lMaxCol = 0 For li = 0 To UBound(alArrBegRows) If alArrBegRows(li) < lMinRow Then lMinRow = alArrBegRows(li) If alArrEndRows(li) > lMaxRow Then lMaxRow = alArrEndRows(li) If alArrBegCols(li) < lMinCol Then lMinCol = alArrBegCols(li) If alArrEndCols(li) > lMaxCol Then lMaxCol = alArrEndCols(li) Next li lEndRow = ActiveSheet.Rows.Count lEndCol = ActiveSheet.Columns.Count 'максимальные пороги If lMaxRow <> lEndRow Then Set rInvertRange = Rows(lMaxRow + 1 & ":" & lEndRow) End If If lMaxCol <> lEndCol Then If Not rInvertRange Is Nothing Then Set rInvertRange = Union(rInvertRange, Range(Cells(1, lMaxCol + 1), Cells(1, lEndCol)).EntireColumn) Else Set rInvertRange = Range(Cells(1, lMaxCol + 1), Cells(1, lEndCol)).EntireColumn End If End If 'минимальные пороги If lMinRow <> 1 Then If Not rInvertRange Is Nothing Then Set rInvertRange = Union(rInvertRange, Rows(1 & ":" & lMinRow - 1)) Else Set rInvertRange = Rows(1 & ":" & lMinRow - 1) End If End If If lMinCol <> 1 Then If Not rInvertRange Is Nothing Then Set rInvertRange = Union(rInvertRange, Range(Cells(1, 1), Cells(1, lMinCol - 1)).EntireColumn) Else Set rInvertRange = Range(Cells(1, 1), Cells(1, lMinCol - 1)).EntireColumn End If End If For li = 0 To UBound(alArrBegRows) 'Если выделен целый столбец/столбцы If alArrEndRows(li) = lEndRow And alArrBegRows(li) = 1 Then bEqualRows = 1 Else bEqualRows = 0 End If 'Если выделена целая строка/строки If alArrEndCols(li) = lEndCol And alArrBegCols(li) = 1 Then bEqualCols = 1 Else bEqualCols = 0 End If Next li 'Если выделены даже несвязанные строки/столбцы целиком If bEqualRows Then lMinRow = lMaxRow If bEqualCols Then lMinCol = lMaxCol 'ячейки "внутри" For lr = lMinRow To lMaxRow For lc = lMinCol To lMaxCol If Intersect_Nums(lr, lc) = False Then If rRng Is Nothing Then If lMinRow = lMaxRow Then Set rRng = Cells(lr, lc).EntireColumn Else If lMinCol = lMaxCol Then Set rRng = Cells(lr, lc).EntireRow Else Set rRng = Cells(lr, lc) End If End If Else If lMinRow = lMaxRow Then Set rRng = Union(rRng, Cells(lr, lc).EntireColumn) Else If lMinCol = lMaxCol Then Set rRng = Union(rRng, Cells(lr, lc).EntireRow) Else Set rRng = Union(rRng, Cells(lr, lc)) End If End If End If End If Next lc Next lr If Not rInvertRange Is Nothing Then If Not rRng Is Nothing Then Set rInvertRange = Union(rRng, rInvertRange) End If Else If Not rRng Is Nothing Then Set rInvertRange = rRng End If End If 'Действия над инвертированным диапазоном If Not rInvertRange Is Nothing Then rInvertRange.Select End If End Sub '--------------------------------------------------------------------------------------- ' Procedure : Intersect_Nums ' Purpose : Функция определения вхождения в диапазон '--------------------------------------------------------------------------------------- Function Intersect_Nums(lr As Long, lc As Long) As Boolean Dim lCntR As Long, lCntC As Long, li As Long For li = LBound(alArrBegRows) To UBound(alArrBegRows) For lCntR = alArrBegRows(li) To alArrEndRows(li) For lCntC = alArrBegCols(li) To alArrEndCols(li) If lr = lCntR Then If lc = lCntC Then Intersect_Nums = True: Exit Function End If Next lCntC Next lCntR Next li End Function |
В приложенном файле примере код усложнен пользовательской формой(UserForm), при помощи которой можно выбрать действие с инвертированным диапазоном: Выделить, Очистит все, Очистить форматы, Очистить значения. Немного поменяв код Вы сможете легко добавить другие действия над диапазоном.
Tips_Macro_Invert_Selection.xls (93,0 КиБ, 2 837 скачиваний)
А всё-таки вариант с временной книгой, предложенный :) , намного проще по коду и очень шустрый:
Согласен, код шустрый и более оптимальный, чем предложенный в данной статье. Но основной целью было не столько реализация инвертирования, сколько реализация без создания листов и книг.