VBA - очистить тысячи ячеек одновременно

Option Explicit

Sub t()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim rng As Range
Set rng = Range("A2:A3") ' this is the range where your named ranges are kept

Dim cel As Range

For Each cel In rng
    Range(cel.Value).ClearContents
Next cel

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

При этом используется словарь, чтобы собрать все именованные диапазоны на соответствующих листах и ​​объединить их в один диапазон, а затем просмотреть эти листы, содержащие именованные диапазоны, и очистить их содержимое. Это должно быть выполнено очень быстро за вас:

РЕДАКТИРОВАТЬ: макрос теперь будет проходить только по именованным диапазонам, которые существуют в указанном списке.

РЕДАКТИРОВАТЬ 2: теперь макрос будет учитывать именованные диапазоны, в которых есть объединенные ячейки.

РЕДАКТИРОВАТЬ 3: макрос теперь будет учитывать именованные диапазоны, которые имеют несколько областей несмежных областей диапазона, где одна или несколько из этих областей являются объединенной ячейкой.

РЕДАКТИРОВАТЬ 4: макрос теперь учитывает возможные ошибки #REF из устаревших именованных диапазонов.

РЕДАКТИРОВАТЬ 5: макрос теперь учитывает листы с пробелами в их именах.

Sub tgr()

    Dim wb As Workbook
    Dim wsNamedRangeList As Worksheet
    Dim rNamedRangeList As Range
    Dim rName As Range
    Dim rTest As Range
    Dim aAreas As Variant
    Dim vArea As Variant
    Dim vName As Variant
    Dim vSheetNamesRange As Variant
    Dim hSheets As Object
    Dim sSheet As String
    Dim sRange As String

    Set wb = ActiveWorkbook
    Set wsNamedRangeList = wb.Sheets("NamedRangeList")  'Change this to the actual name of the worksheet containing the list of named range names
    Set rNamedRangeList = wsNamedRangeList.Columns("A") 'Change this to the actual column containing the list of named range names
    Set hSheets = CreateObject("Scripting.Dictionary")

    For Each vName In wb.Names
        Set rTest = rNamedRangeList.Find(vName.Name, , xlValues, xlWhole, , , False)
        If Not rTest Is Nothing Then
            aAreas = Split(vName, ",")
            For Each vArea In aAreas
                sSheet = Split(vArea, "!")(0)
                If Left(sSheet, 1) = " = " Then sSheet = Mid(sSheet, 2)
                If Left(sSheet, 1) = "'" Then sSheet = Mid(sSheet, 2, Len(sSheet) - 2)
                sRange = Split(vArea, "!")(1)
                If sSheet <> "#REF" And sRange <> "#REF" Then
                    Set rName = wb.Sheets(sSheet).Range(sRange)
                    If hSheets.Exists(sSheet) Then
                        Set hSheets(sSheet) = Union(hSheets(sSheet), rName.MergeArea)
                    Else
                        Set hSheets(sSheet) = rName.MergeArea
                    End If
                End If
            Next vArea
        End If
    Next vName

    For Each vSheetNamesRange In hSheets.Items
        vSheetNamesRange.ClearContents
    Next vSheetNamesRange

End Sub

Option Explicit

Sub t()
On Error GoTo exitErr
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim rng As Range
Set rng = Range("A2:A3") ' this is the range where your named ranges are kept

Dim nmRng As Range, cel As Range

For Each cel In rng
    Range(cel.Value).ClearContents
Next cel

ExitErr:
   Application.ScreenUpdating = True
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic

End Sub

@BruceWayne - ПОЖАЛУЙСТА, обработка ошибок. Почему это так важно?? Что произойдет, если один из диапазонов в списке отсутствует? Ваш код ломается, обновление экрана прекращается, события не запускаются, и ваши формулы перестают вычисляться, так как они были выключены и больше никогда не включаются.

Вызов ClearNamedRanges с диапазоном имен, который вы хотите очистить

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

Обновлено: я считаю, что Application.Match может работать быстрее, чем Range.Find Test, оба дайте мне знать.

Sub Test()
    Call ClearNamedRanges(Sheet1.Range("A1:A35000"))
End Sub

Private Sub ClearNamedRanges(ByRef oNameRange As Range)

    Dim oName As Name
    For Each oName In ActiveWorkbook.Names
        'if Not IsError(Application.Match(oName.Name, oNameRange, 0)) Then oName.RefersToRange.ClearContents
        If Not oNameRange.Find(oName.Name) Is Nothing Then oName.RefersToRange.ClearContents
    Next
End Sub

Мне любопытно посмотреть, будет ли это вообще быстрее. Вместо того, чтобы обращаться к листу дважды, .Range и Cells, я просматриваю массив так, чтобы в цикле была только одна ссылка на лист.

Sub cleartest()

    Dim RangeNames() as Variant

    RangeNames = Worksheets("Sheet1").Range("A1:A35000").value
    For i = 1 To 35000
        With Sheets("Sheet1")
            .Range(RangeNames(i,1)).ClearContents
        End With
    Next i

End Sub

Что-то еще, что можно попробовать, может быть использование .Range(RangeNames(i,1)).Value = vbNullString, если вы просто хотите очистить значения. Я не думаю, что это очистит форматирование.

вы можете попробовать управлять только непустыми «объектами» (ячейками с именованным именем диапазона и самими именованными диапазонами)

Sub clear()
    Dim namedRangeCells As Range, cell As Range

    With Sheets("Sheet1") ' reference your sheet
        Set namedRangeCells = .Cells(1, 1) ' set namedRangeCells to a cell you don't care about
        For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop thropugh referenced sheet column A not empty cells
            Set namedRangeCells = Union(namedRangeCells, .Range(cell.Value)) ' collect named ranges
        Next
    End With

    namedRangeCells.SpecialCells(xlCellTypeConstants).ClearContents ' clear collected named ranges with with not empty value
End Sub