Согласен, название статьи звучит страшно и не совсем понятно. Поэтому явно надо разъяснить поподробнее. Начну с предыстории. На одном форуме форумчанин задал вопрос - "Как инвертировать 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 скачиваний)

Loading

2 комментария

  1. А всё-таки вариант с временной книгой, предложенный :) , намного проще по коду и очень шустрый:

    Sub InvertSelection()
    '---------------------------------------------------------------------------------------
    ' Procedure : InvertSelection
    ' Author    : :)
    ' URL       : http://www.planetaexcel.ru/forum.php?thread_id=14008
    ' DateTime  : 04.03.2010   00:17
    ' Purpose   : инвертировать Selection
    ' Notes     : Работает со всеми ячейками листа, поддерживается выделение нескольких несмежных диапазонов.
    ' Notes     : в процессе работы создаётся временный ЛИСТ в текущей книге, поэтому может не работать при защищенной структуре книги
    '---------------------------------------------------------------------------------------
        If Not TypeName(Selection) = "Range" Then Exit Sub
        With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
        Dim selAddr As String: selAddr = Selection.Address
        With ActiveSheet
            With Worksheets.Add
                .Cells.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="0"
                .Range(selAddr).ClearFormats
                selAddr = .Cells.SpecialCells(xlCellTypeAllFormatConditions).Address
                .Delete
            End With
            .Range(selAddr).Select
        End With
        With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
    End Sub

Добавить комментарий

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.