Как исключить ячейку Х из диапазона А

[Step_UA]

Время не замерял, но должно быть значительно быстрее
... необходимо скорректировать для случаев, когда строка Address диапазона длинее 255 символов

Function DellRange(A As Range, X As Range) As Range
  Dim sh As Worksheet: Set sh = ActiveSheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    With ActiveWorkbook.Worksheets.Add
        .Range(A.Address).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="0"
        .Range(X.Address).ClearFormats
        Set DellRange = sh.Range(.Cells.SpecialCells(xlCellTypeAllFormatConditions).Address)
        .Delete
    End With
    Set sh = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Function

Sub test()
    DellRange([A:C], [b2,c4]).Select
End Sub

[Казанский]

Step_UA,
отличная свежая идея!

Я немного подправил, чтобы уйти от привязки к activesheet и еще кое-что, описано в коментах.

Function DellRange(A As Range, X As Range) As Range
  Dim aSh As Worksheet          'лист, содержащий диапазон А
  Dim scrUpd, dispAl, enEven    'переменные для сохранения состояния приложения
  Set aSh = A.Worksheet
'Проверяем, что диапазоны принадлежат одному листу.
'Если нет, error 1004, как при Intersect диапазонов из разных листов
  If Not aSh Is X.Worksheet Then
    Err.Raise 1004, , "Ranges from different sheets"
    Exit Function
  End If
'сохранение и изменение состояния приложения
  With Application
    scrUpd = .ScreenUpdating: .ScreenUpdating = False
    dispAl = .DisplayAlerts: .DisplayAlerts = False
    enEven = .EnableEvents: .EnableEvents = False
  End With
'создание листа в книге с диапазонами
  With aSh.Parent.Worksheets.Add
    .Range(A.Address).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="0"
    .Range(X.Address).ClearFormats
    On Error Resume Next    'на случай, если ячейки не будут найдены
    Set DellRange = aSh.Range(.Cells.SpecialCells(xlCellTypeAllFormatConditions).Address)
    .Delete
  End With
'восстановление состояния приложения
  Application.ScreenUpdating = scrUpd
  Application.DisplayAlerts = dispAl
  Application.EnableEvents = enEven
End Function

[Step_UA]

Сообщение от Казанский

Я немного подправил, чтобы уйти от привязки к activesheet ...

Скорее это была ошибка, а не привязка - переделывал из кода на vb.net на быструю руку
... дополнил немного

Function DellRange(A As Range, X As Range) As Range
  Dim aSh As Worksheet          'лист, содержащий диапазон А
  Dim scrUpd, dispAl, enEven    'переменные для сохранения состояния приложения
  Dim Ar As Range, tmp As Range
  Set aSh = A.Worksheet
'Проверяем, что диапазоны принадлежат одному листу.
'Если нет, error 1004, как при Intersect диапазонов из разных листов
  If Not aSh Is X.Worksheet Then
    Err.Raise 1004, , "Ranges from different sheets"
  End If
'сохранение и изменение состояния приложения
  With Application
    scrUpd = .ScreenUpdating: .ScreenUpdating = False
    dispAl = .DisplayAlerts: .DisplayAlerts = False
    enEven = .EnableEvents: .EnableEvents = False
  End With
'создание листа в книге с диапазонами
  With aSh.Parent.Worksheets.Add
    For Each Ar In A.Areas
      .Range(Ar.Address).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="0"
    Next
    For Each Ar In X.Areas
      .Range(Ar.Address).ClearFormats
    Next
    Set tmp = .Cells.SpecialCells(xlCellTypeAllFormatConditions)
    If Not tmp Is Nothing Then
      For Each Ar In tmp.Areas
        If DellRange Is Nothing Then
          Set DellRange = aSh.Range(Ar.Address)
        Else
          Set DellRange = Application.Union(DellRange, aSh.Range(Ar.Address))
        End If
      Next
    End If
    .Delete
  End With
'восстановление состояния приложения
  Application.ScreenUpdating = scrUpd
  Application.DisplayAlerts = dispAl
  Application.EnableEvents = enEven
End Function

Sub test()
  Dim R As Range, i&
  Set R = [a1]
  For i = 3 To 500 Step 2
    Set R = Application.Union(R, Cells(i, 1))
  Next
  DellRange(R, [a3,a7]).Select
End Sub

[IgorGO]

Step_UA, спасибо!

я пришел к тому же. см. здесь дополнительный лист, перенос туда исходного диапазона как адреса, заполнение диапазона единичками, очистка удаляемых ячеек и получение нового диапазона через Cells.SpecialCells(xlCellTypeConsta nts), получение адреса и перенос его на исходный лист.

думаю, что навесить условный формат и удалить его где надо еще более быстрый способ.

полезную функцию уже можно положить в библиотеку, но... ждем'с, программисты еще есть на форуме

[SAS888]

Хорошая идея. Не проверял, но может, что так будет еще быстрее:

Function DellRange(A As Range, X As Range) As Range
    Dim s As String, scrUpd, dispAl, enEven
    If Not A.Worksheet Is X.Worksheet Then Err.Raise 1004, , "Ranges from different sheets"
    With Application
        scrUpd = .ScreenUpdating: .ScreenUpdating = False
        dispAl = .DisplayAlerts: .DisplayAlerts = False
        enEven = .EnableEvents: .EnableEvents = False
        Sheets.Add
        Range(X.Address) = 1: Cells(Rows.Count, Columns.Count) = 1
        s = Range(A.Address).SpecialCells(xlCellTypeBlanks).Address
        ActiveSheet.Delete
        Set DellRange = Range(s)
        .ScreenUpdating = scrUpd: .DisplayAlerts = dispAl: .EnableEvents = enEven
    End With
End Function

Единичка в последней ячейке листа нужна потому, что метод SpecialCells(xlCellTypeBlanks) применяется только к UsedRange.

[IgorGO]

Хорошо, спасибо!

только, видимо, финальное присвоение значения функции нужно так написать:

Set DellRange = A.Parent.Range(s)