VBA命名范围检查名称是否存在的最有效方法

Question

我有一个例行程序，在日历上填满下一周每一天的商品市场的所有重要事件。我在页面上布置了一个日历网格，并且在每一天的列中每天都有十个命名单元格，即 Monday1、Monday2 等等（现在每天最多只能达到 10 个，即Monday10）。顺便说一句，单元格宽 2 格，深 2 格。很多时候，一天有超过 10 个事件。我正在尝试测试命名范围以查看它是否存在，如果不存在，则复制最后一个命名范围单元格的格式并将该单元格命名为系列中的下一个名称。

我对上述问题只有两个问题，首先是如何测试以确定命名范围的名称已经存在。我目前正在遍历 ThisWorkbook.Names 的整个列表，其中包含数千个命名范围。由于在生成日历时此迭代可能会运行超过 100 次，因此速度非常慢（正如预期的那样）。是否有更好、更快的方法来检查名称是否已作为命名范围存在？

第二个问题是如何复制 4 个单元格的格式，合并单元格，因为地址总是仅作为左上角单元格出现，因此偏移范围无法正常工作。为了让这段代码至少为列中的下一个合并单元组提供正确的范围，我四处乱窜

Set cCell = Range("Thursday" & CStr(y))
'even tho cCell is a 4 cell merged cell, cCell.Address returns the address of top left cell
Set destRange = Range(cCell.Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)

录制宏以向下拖动格式，显示此​​代码。

Range("G22:H23").Select
Selection.AutoFill Destination:=Range("G22:H25"), Type:=xlFillFormats
Range("G22:H25").Select

由于 Range("G22:H23") 与 cCell 相同，Range("G22:H25") 与 destRange 相同。以下代码应该可以工作，但不能。

Set cCell = Range("Thursday" & CStr(y))
Set destRange = Range(cCell.Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)
cCell.AutoFill Destination:=destRange, Type:=xlFillFormats
Application.CutCopyMode = False
cCell.offset(1, 0).Name = rangeName

仅供参考，如果我选择 cCell 并使用 Selection.AutoFill 也不起作用。

对于如何在需要时将单元格格式一次复制一个单元格，有什么想法吗？

更新：

这现在适用于将格式从一个合并单元格复制到另一个相同大小的单元格。出于某种原因，将 destRange 设置为整个范围（宏记录器显示的复制单元格和 pastecell 整个范围）不起作用，但将 destRange 设置为需要格式化的单元格范围，然后将 cCell 和 destRange 合并，并进行命名新范围更容易。

rangeName = "Friday" & CStr(y + 1)
priorRangeName = "Friday" & CStr(y)
namedRangeExist = CheckForNamedRange(rangeName)
If namedRangeExist = False Then
    Set cCell = Range(priorRangeName) 
    Set destRange = Range(cCell.offset(1, 0).Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)
    cCell.AutoFill Destination:=Union(cCell, destRange), Type:=xlFillFormats
    Application.CutCopyMode = False
    destRange.Name = rangeName
End If

更新 #2

在 For 循环中命名范围存在问题（下面的代码在 For 循环中运行）。第一次找不到新的范围名称时，将 cCell 设置为先前的范围名称并运行代码以复制合并的单元格格式并命名新范围工作正常。这是代码

rangeName = "Thursday" & CStr(y + 1)
priorRangeName = "Thursday" & CStr(y)
namedRangeExist = DoesNamedRangeExist(rangeName)
If namedRangeExist = False Then
    Set cCell = Range(priorRangeName)
    Debug.Print "cCell:" & cCell.Address
    Set cCell = cCell.MergeArea
    Debug.Print "Merged cCell:" & cCell.Address
    Set destRange = Range(cCell.offset(1, 0).Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)
    Debug.Print "Dest:" & destRange.Address
    Debug.Print "Unioned:" & Union(cCell, destRange).Address
    cCell.AutoFill Destination:=Union(cCell, destRange), Type:=xlFillFormats
    Application.CutCopyMode = False
    destRange.name = rangename
End If

结果在以下范围内

cCell:$G$22

合并的 cCell:$G$22:$H$23

目标：$G$24:$H$25

工会：$G$22:$H$25

但是如果第二次需要创建多个新的命名范围，则此代码会生成一个范围区域，如下所示的输出所示

cCell:$G$24:$H$25

那么为什么第一次运行时cCell的地址只显示为左上角的单元格地址，而第二次通过cCell的地址显示为整个合并的单元格范围？因为它确实如此，所以下一个代码行会产生一个范围对象错误

Set cCell = cCell.MergeArea

删除该代码行并将第一个 Set cCell 修改为此；

Set cCell = Range(priorRangeName).MergeArea

产生相同的错误。我可以通过设置一个计数器来解决这个问题，如果有多个，则绕过该代码行，但这不是首选解决方案。

Answer 1

首先，创建一个函数来调用命名范围。如果调用命名范围产生错误，该函数将返回 False，否则将返回 True。

Function NameExist(StringName As String) As Boolean
    Dim errTest As String

    On Error Resume Next

    errTest = ThisWorkbook.Names(StringName).Value

    NameExist = CBool(Err.Number = 0)

    On Error GoTo 0
End Function

关于你的第二个问题，我对自动填充没有问题。

我会将Set destRange = Range(cCell.Address & ":" & cCell.offset(2, 0).offset(0, 1).Address) 替换为Set destRange = cCell.Resize(2,1)。它具有相同的效果，但后者更清洁。

Answer 2

Application.Evaluate 和Worksheet.Evaluate 可用于获取错误值而不是错误：

If Not IsError(Evaluate("Monday1")) Then             ' if name Monday1 exists

---

可以忽略或跳过错误（但这会导致难以检测到错误）：

 On Error GoTo label1
   ' code that can result in error here
 label1:
 If Err.Number <> 0 Then Debug.Print Err.Description ' optional if you want to check the error
 On Error GoTo 0                                     ' to reset the error handling

---

Range.MergeArea 可用于获取合并单元格的范围。

Answer 3

我创建了一个函数来扩展名称范围并填写格式。必须设置系列中的第一个命名范围。名称本身需要设置在合并区域的左上角单元格中。

ExtendFillNamedRanges 将计算命名范围的位置。如果其中一个位置的单元格不是 MergedArea 的一部分，它将从最后一个命名范围向下填充格式。它将命名该单元格。名称的范围是 Workbook。

Sub ExtendFillNamedRanges(BaseName As String, MaxCount As Integer)
    Dim x As Integer, RowCount As Integer, ColumnCount As Integer

    Dim LastNamedRange As Range, NamedRange As Range

    Set NamedRange = Range(BaseName & 1)

    RowCount = NamedRange.MergeArea.Rows.Count
    ColumnCount = NamedRange.MergeArea.Columns.Count

    For x = 2 To MaxCount
        Set NamedRange = NamedRange.Offset(RowCount - 1)
        If Not NamedRange.MergeCells Then
            Set LastNamedRange = Range(BaseName & x - 1).MergeArea
            LastNamedRange.AutoFill Destination:=LastNamedRange.Resize(RowCount * 2, ColumnCount), Type:=xlFillDefault
            NamedRange.Name = BaseName & x

        End If

        'NamedRange.Value = NamedRange.Name.Name
    Next

End Sub

这是我运行的测试。

Sub Test()
    Application.ScreenUpdating = False
    Dim i As Integer, DayName As String

    For i = 1 To 7
        DayName = WeekDayName(i)

        Range(DayName & 1).Value = DayName & 1

        ExtendFillNamedRanges DayName, 10
    Next i

    Application.ScreenUpdating = True
End Sub

之前：

之后：

Answer 4

我找到了this on ozgrid，并用它做了一个小功能：

Option Explicit

Function DoesNamedRangeExist(VarS_Name As String) As Boolean
Dim NameRng As Name

For Each NameRng In ActiveWorkbook.Names
    If NameRng.Name = VarS_Name Then
        DoesNamedRangeExist = True
        Exit Function
    End If
Next NameRng

DoesNamedRangeExist = False
End Function

你可以在你的代码中加入这一行来检查：

DoesNamedRangeExist("Monday1")

它将返回一个布尔值 (True / False)，因此很容易与 IF() 语句一起使用

关于您关于合并单元格的问题，我在 2*2 合并单元格上做了一个快速宏记录，它给了我这个（变小并添加了 cmets）：

Sub Macro1()
    Range("D2:E3").Copy 'Orignal Merged Cell
    Range("G2").PasteSpecial xlPasteAll 'Top left of destination
End Sub