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

Question

我有一个惯例，在日历中填满下周每一天商品市场的所有重要事件。我在页面上布置了一个日历网格，并在每天列中每天有 10 个命名单元格，即 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 设置为整个范围(宏记录器显示的复制单元格和粘贴单元整个范围)不起作用，但将 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)。它具有相同的效果，但后者更干净。