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