检查单元范围后，没有一个范围名称

Question

我正在尝试根据电子表格上的文本值循环选择细胞并重命名这些单元格。

Sub naming()

    Dim cel As Range
    Dim selectedRange As Range
    Dim to_offset As Integer

    Set selectedRange = Application.Selection

    Answer = InputBox("Column Where Named Are?")
    col_number = Range(Answer & 1).Column

    For Each cel In selectedRange.Cells
        cel.Name.Delete
        to_offset = col_number - cel.Column
        cel.Name = cel.Offset(0, to_offset).Value
    Next cel

End Sub

删除命令是问题 - 因此，我想我会使用Len（）检查名称，但要获得1004错误。

如果没有为单元格定义的名称，则它可以工作（但我不能将删除代码留在中）。
如果已经为单元格定义了名称（并且我使用删除）。

我需要将删除用于现有名称 - 但要跨越空白名称。

Answer 1

一种快速而肮脏的方法是在错误简历上之间包裹有问题的

    On Error Resume Next   'skip line in case of an error
    cel.Name.Delete
    On Error GoTo 0        'reset error handling

行错误恢复Next 告诉VBA忽略错误并继续。在某些情况下，这很有用。大多数时候，您应该避免使用它。我认为这可能是您可以使用它的情况。

或者，您将代码包裹在子中

Sub deleteName(rg As Range)

    On Error GoTo EH
    rg.Name.Delete
    
    Exit Sub

EH:
    
End Sub

并使用它，

For Each cel In selectedRange.Cells
        deleteName cel
        to_offset = col_number - cel.Column
        cel.Name = cel.Offset(0, to_offset).Value
Next cel

但是在这种情况下，这是恕我直言不讳的。

在错误处理上的进一步阅读

Answer 2

中删除名称的快速而直接的方法。

除了@storax'ES解决方案外，您可能会受益于相对未知函数 /en-us/office/vba/api/excel.range.value“ rel =” nofollow noreferrer“> rng.value（xlrangevaluexmlspreadsheet） 所选范围的所有现有名称为XML字符串。这节省了进一步的错误处理。

将它们分配给数组并在循环中删除以下内容：

Option Explicit                           ' code module header

Sub DelNamesInSelectedRange()
'a) Define selected range by any method
    Dim selectedRng As Range
    Set selectedRng = Application.Selection
'b) Get all names in selected range via XMLSpreadsheet analyze
    Dim myNames
    myNames = GetNames(selectedRng)
'c) Delete received names
    Dim i As Long
    For i = 1 To UBound(myNames) - 2
        ThisWorkbook.Names(myNames(i)).Delete
    Next
End Sub

help函数 getNames（）

应用一些 xml 逻辑，包括命名空间， XPATH搜索字符串*允许提取指定范围的所有名称，并返回所有现有名称的数组。

此XML的样品提取物可能是：

<?xml version="1.0"?>
<?mso-application progid="Excel.Sheet"?>
<Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet"
 xmlns:o="urn:schemas-microsoft-com:office:office"
 xmlns:x="urn:schemas-microsoft-com:office:excel"
 xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"
 xmlns:html="http://www.w3.org/TR/REC-html40">
' <!-- ... omitting styles etc -->
' <!-- ... -->
' <Names>
'  <NamedRange ss:Name="FirstName" ss:RefersTo="=Sheet1!R1C1"/>
'  <NamedRange ss:Name="SecondName" ss:RefersTo="=Sheet1!R3C1"/>
'  <NamedRange ss:Name="LastName" ss:RefersTo="=Sheet1!R2C3"/>
' </Names>
' <!-- ... -->
'</Workbook>

Function GetNames(rng As Range)
'[0]Get Value(11)
    Dim s As String
    s = rng.Value(xlRangeValueXMLSpreadsheet)   ' or: rng.Value(11)
'[1]Set xml document to memory
    Dim xDoc As Object: Set xDoc = CreateObject("MSXML2.DOMDocument.6.0")
'[2]Add namespaces
    xDoc.SetProperty "SelectionNamespaces", _
    "xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet' " & _
    "xmlns:ht='http://www.w3.org/TR/REC-html40'"
'[3]Get cells with Names/NamedRange/@Name
    If xDoc.LoadXML(s) Then            ' load wellformed string content
        Dim cell As Object, cells As Object
        'Set cells = xDoc.SelectNodes("//ss:Cell[ss:Data/@ss:Type='Number']") ' XPath using namespace prefixes
        Set cells = xDoc.SelectNodes("//ss:Names/ss:NamedRange/@ss:Name") ' XPath using namespace prefixes
        Dim tmp(): ReDim tmp(1 To cells.Length)
        For Each cell In cells
            Dim i As Long: i = i + 1
            tmp(i) = cell.Text
        Next cell
        '[4]return "flat" array
        GetNames = tmp
    End If
End Function