Question

我正在寻找一个简单的宏，用于为具有此设计的表创建动态命名范围：

       A      B
4    Title1 Title2
5    val_1  val_a
6    val_2  val_b
7    val_3  val_3

要求是：

动态命名范围的名称应该等于标题（在本例中为“Title1”，“Title2”）。
应该能够指定标题所在的行（例如第4行）。

（我发现了两个这样的宏（1，2），但它们都有第二个要求的错误。）

Answer 1

这是Roger Govier代码的黑客版本

Sub CreateNames()
   Dim wb                     As Workbook
   Dim ws                     As Worksheet
   Dim rStartCell             As Range
   Dim rData                  As Range
   Dim rCol                   As Range
   Dim LastCol                As Long
   Dim lCol                   As Long
   Dim sSheet                 As String
   Dim Rowno                  As Long

   ' get table location
   On Error Resume Next
   Set rStartCell = Application.InputBox(prompt:="Select top left cell of table", Title:="Select first cell", Default:=ActiveCell, Type:=8)
   On Error GoTo err_handle
   If rStartCell Is Nothing Then Exit Sub

   Set ws = rStartCell.Worksheet
   Set wb = ws.Parent
   sSheet = "'" & ws.Name & "'"
   With rStartCell
      Rowno = .Row
      Set rData = .CurrentRegion
   End With

   ' get column count
   With rData
      LastCol = .Column + .Columns.Count - 1
   End With
   ' reset data range
   Set rData = ws.Range(rStartCell, ws.Cells(Rowno, LastCol))

   For Each rCol In rData.Columns

      lCol = rCol.Column
      wb.Names.Add Name:=Replace(rCol.Cells(1).Value, " ", "_"), _
                   RefersToR1C1:="=" & sSheet & "!" & rCol.Cells(1).Address(ReferenceStyle:=xlR1C1) & ":INDEX(C" & lCol & ",LOOKUP(2,1/(C" & lCol & "<>""""),ROW(C" & lCol & ")))"

   Next rCol

   MsgBox "All dynamic Named ranges have been created"
   Exit Sub

err_handle:

   MsgBox "Error " & Err.Number & " (" & Err.Description & _
          ") in procedure CreateNames"

End Sub

用于动态命名范围的Excel VBA宏

1 个答案: