根据列中的值创建命名范围

Question

我想根据 B 列中的值创建命名范围。

例如

我要创作

范围名称：UNIT21，从上面的数据来看，RefersTo 应该是 A2:C4 和 A6:C6.
名称范围：UNIT22 用于 B 列中包含 22 的数据。

如何 select 从 A:C 的整行到相应的行？
如何将新数据添加到现有命名范围，而不是像我的代码那样替换现有值。

Sub naming()
    Dim row_index As Long
    Dim lastrow As Long: lastrow = 5
    
    Dim NamedRange As Range
    Dim celltomap As Range
    
    Dim Rng As Range
    
    For row_index = 1 To lastrow
    
        RangeName = Sheet3.Range("A2:C6").Cells(row_index, 2).Value
        Set celltomap = Sheet3.Range("A2:C6").Cells(row_index, 3)
        
        Sheet3.Names.Add Name:="UNIT" & RangeName, RefersTo:=celltomap
     
        MsgBox ("UNIT" & RangeName)
    
    Next row_index
    
End Sub

cross-posted

Answer 1

应该这样做：

Option Explicit

Sub naming()
    Dim row_index As Long
    Dim lastrow As Long: lastrow = 5

    Dim celltomap As Range
    Dim RangeName As String
    Dim nm As Name

    For row_index = 1 To lastrow
        RangeName = Foglio1.Range("A2:C6").Cells(row_index, 2).Value
        Set celltomap = Foglio1.Range("A2:C6").Cells(row_index, 3)

        On Error Resume Next
        Set nm = Foglio1.Names("UNIT" & RangeName)
        On Error GoTo 0

        If nm Is Nothing Then ' first time you hit "UNIT" & RangeName -> set a new name
            Foglio1.Names.Add Name:="UNIT" & RangeName, RefersTo:=celltomap
        Else ' name already there -> update its 'RefersTo' property
            nm.RefersTo = Union(nm.RefersToRange, celltomap)
        End If
        Set nm = Nothing ' initialize 'nm' for subsequent 'If nm Is Nothing Then' check
    Next
End Sub

如您所见，我坚持原来的 celltomap 设置模式，即：仅列 "C" 单元格，但您可以轻松地闪烁代码并扩展到更多列

Answer 2

运行下面的代码，它将创建范围名称。

如果列表在您运行代码之前未排序，则命名范围的值将为 {...}。

Sub NameRanges()

    Dim cUnique As Collection
    Dim Rng As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant
    Dim FrstRng As Range
    Dim UnionRng As Range
    Dim c As Range

    Set sh = ThisWorkbook.Sheets("Sheet1")
    With sh
        Set Rng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        Set cUnique = New Collection

        On Error Resume Next
        For Each Cell In Rng.Cells
            cUnique.Add Cell.Value, CStr(Cell.Value)
        Next Cell
        On Error GoTo 0

        For Each vNum In cUnique
            For Each c In Rng.Cells
                If c = vNum Then
                    If Not UnionRng Is Nothing Then
                        Set UnionRng = Union(UnionRng, c.Offset(, 1))   'adds to the range
                    Else
                        Set UnionRng = c.Offset(, 1)
                    End If
                End If
            Next c

            UnionRng.Name = "Unit" & vNum
            Set UnionRng = Nothing
        Next vNum
    End With

End Sub

有时您可能想要删除范围名称并重新开始。

Sub delete_RngNames()
    Dim rn As Name
    For Each rn In ActiveWorkbook.Names
        rn.Delete
    Next rn
End Sub

您没有在工作表或用户窗体上指定 ActiveX 组合框。

这应该适用于两者，只是按钮名称可能不同。

Private Sub CommandButton1_Click()
    Dim s As String, rng As Range, c As Range

    s = "Unit" & Me.TextBox1

    Me.ComboBox1.Clear

    For Each c In Range(s).Cells
        Me.ComboBox1.AddItem c
    Next c

End Sub

此代码假定您已在文本框中输入内容。组合 "Unit" 和文本框将指示填充组合框的范围

根据列中的值创建命名范围

Creating named range based on value in column

excel

vba

named-ranges