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

Question

我有一个例程，它为下周的每一天的商品市场的所有重要事件填充日历。我在页面上布置了一个日历网格，并且每天有十个命名单元格，即星期一1，星期一2等等（现在每天只有最多10个，即星期10）。顺便说一句，这些细胞是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 

由于范围（ “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循环）的问题。第一次没有找到新的rangeName，将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

但如果超过一个新的指定范围必须CRE重复的信号第二次通过这个代码产生如由下面所示

CCELL的输出的范围面积：$ G $ 24：$ H $ 25

所以为什么CCELL的地址显示为仅左上细胞地址时，运行第一次，但第二次通过cCell的地址显示为整个合并单元格范围？并且因为它，下一个代码行生产一系列对象错误

Set cCell = cCell.MergeArea 

消除该代码线和修改所述第一组CCELL此;

Set cCell = Range(priorRangeName).MergeArea 

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

Answer 1

我创建了一个功能扩展名的范围，并在填写格式。系列中第一个命名的范围将被设置。名称本身需要设置在合并区域的左上方单元格中。

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 2

我发现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") 

它会返回一个布尔值（真/假）所以它很容易使用IF()声明

至于你对合并单元格的问题，我做了一个2 * 2合并单元格的快速宏记录，它给了我这（做小和增加评论）：

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

Answer 3

首先，创建一个函数来调用命名的范围。如果调用命名范围产生错误，函数将返回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 = cCell.Resize(2,1)来回报Set destRange = Range(cCell.Address & ":" & cCell.offset(2, 0).offset(0, 1).Address)。它具有相同的效果，但后者更清洁。

Answer 4

最有效的方法是不检查它是否存在。相反，你可以忽略错误并继续：

On Error GoTo label1 
    ' your code 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 On Error GoTo label1 

要获得合并单元格的范围，你可以使用cCell.MergeArea
https://msdn.microsoft.com/en-us/library/office/ff822300.aspx