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

Question

我正在寻找一个简单的宏来为具有这种设计的表创建动态命名范围：

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

要求是：

1. 动态命名范围的名称应与标题相同（在本例中为“Title1”、“Title2”）。

2. 应该能够指定标题位于哪一行（例如第 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