动态创建命名单元

Posted 2023-02-19

【中文标题】动态创建命名单元

【英文标题】：Create a named cell dynamically

【发布时间】：2013-08-24 05:54:54

【问题描述】：

我有一个包含 3 个工作表的工作簿。一个工作表将具有输入值（目前未创建且此问题不需要），一个具有多个“模板”或“源”表的工作表，最后一个工作表具有 4 个格式化的“目标”表（是否为空）没关系）。每个模板表有 3 列，其中一列标识后两列中的值是什么。值列中包含公式，并且每个单元格都已命名。公式使用单元格名称而不是单元格地址（例如 MyData1 而不是 C2）。

我正在尝试将模板复制到目标表中，同时还将单元格名称从源复制到目标中，或者根据源单元格名称在目标表中创建名称。我在下面的代码中通过在名称中使用“基”来创建目标名称，该名称将根据它被复制到的目标表而改变。我的示例表在所有单元格名称中都有“Num0_”作为基础（例如 Num0_MyData1、Num0_SomeOtherData2 等）。复制完成后，代码将通过查看目标名称（和地址）来命名单元格，用新的基础替换名称的基础，只需添加一些目标表，然后替换工作表地址中的名字。

这是我需要帮助的地方。仅当我的模板和目标使用其透视表的相同单元格地址时，我更改该地址的方式才有效。他们不是。 （例如，Template1 表具有 B2 到 C10 的值单元格，每个都命名为 B2 到 C10，而我的副本目标表可能是 F52 到 G60）。底线我需要弄清楚如何使用模板复制这些名称或通过执行诸如替换之类的操作来动态命名单元格，其中我根据我的目标表增加地址值#...请记住我有 4 个目标表是静态的，我只会复制到那些区域。我是 VBA 新手，因此感谢您提供任何建议或帮助。

注意：表格的复制可以按我的意愿进行。它甚至命名单元格（如果模板和目标表具有相同的本地工作表单元格地址（例如 C2）

'Declare Module level variables
'Variables for target tables are defined in sub's for each target table.
Dim cellName As Name
Dim newName As String
Dim newAddress As String
Dim newSheetVar
Dim oldSheetVar
Dim oldNameVar
Dim srcTable1

Sub copyTables()

newSheetVar = "TestSheet"
oldSheetVar = "Templates"
oldNameVar = "Num0_"
srcTable1 = "TestTableTemplate"

'Call sub functions to copy tables, name cells and update functions.
copySrc1Table
copySrc2Table
End Sub

'****there is another sub identical to this one below for copySrc2Table. 
Sub copySrc1Table()

newNameVar = "Num1_"
trgTable1 = "SourceEnvTable1"
    Sheets(oldSheetVar).Select
    Range(srcTable1).Select
    Selection.Copy
    For Each cellName In ActiveWorkbook.Names
    'Find all names with common value
        If cellName.Name Like oldNameVar & "*" Then
      'Replace the common value with the update value you need
        newName = Replace(cellName.Name, oldNameVar, newNameVar)
        newAddress = Replace(cellName.RefersTo, oldSheetVar, newSheetVar)
      'Edit the name of the name. This will change any formulas using this name as well
        ActiveWorkbook.Names.Add Name:=newName, RefersTo:=newAddress
        End If
    Next cellName
    Sheets(newSheetVar).Select
    Range(trgTable1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False

End Sub

【参考方案1】：

我已经更新了您的 copySrc1Table() 过程，删除了设置 newAdress 行上的 find 方法。我已将其替换为首先设置为源 cellname.refers 值的字符串。这个值被发送到一个新的子（子 UpdateRefersTo），它将它的值更改为所需的值，然后用于设置 newAdress 值

'****there is another sub identical to this one below for copySrc2Table.
Sub copySrc1Table()
Dim trgTable1
Dim vSplitAdress As Variant
Dim sRefersTo As String

newNameVar = "Num1_"
trgTable1 = "SourceEnvTable1"
    Sheets(oldSheetVar).Select
    Range(srcTable1).Select
    Selection.Copy
    Sheets(newSheetVar).Select
    Range(trgTable1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False

    For Each cellName In ActiveWorkbook.Names
    'Find all names with common value
        If cellName.Name Like oldNameVar & "*" Then
      'Replace the common value with the update value you need
        sRefersTo = cellName.RefersTo
        Call UpdateRefersTo(sRefersTo)
        newName = Replace(cellName.Name, oldNameVar, newNameVar)
        newAddress = sRefersTo
      'Edit the name of the name. This will change any formulas using this name as well
        ActiveWorkbook.Names.Add Name:=newName, RefersTo:=newAddress
        End If
    Next cellName

它使用 case 元素执行此操作，因此对于模板工作表中的每个地址，您需要为名为 range 的测试表应引用的内容编写 case 语句。不是一个优雅的解决方案，但它应该可以工作。当然，你仍然需要更改新表中的函数，但这应该不会太难。

End Sub

Sub UpdateRefersTo(ByRef sRefersTo As String)
Dim sString As String

Select Case sRefersTo
    Case "=Templates!$B$2"
        sRefersTo = "=TestSheet!$F$52"
    Case "=Templates!$B$3"
        sRefersTo = "=TestSheet!$F$53"
    Case "=Templates!$B$4"
        sRefersTo = "=TestSheet!$F$54"
    Case "=Templates!$B$5"
        sRefersTo = "=TestSheet!$F$55"
    Case "=Templates!$B$6"
        sRefersTo = "=TestSheet!$F$56"
    Case "=Templates!$B$7"
        sRefersTo = "=TestSheet!$F$57"
    Case "=Templates!$B$8"
        sRefersTo = "=TestSheet!$F$58"
    Case "=Templates!$B$9"
        sRefersTo = "=TestSheet!$F$59"
    Case "=Templates!$B$10"
        sRefersTo = "=TestSheet!$F$60"
    Case "=Templates!$C$2"
        sRefersTo = "=TestSheet!$G$52"
    Case "=Templates!$C$3"
        sRefersTo = "=TestSheet!$G$53"
    Case "=Templates!$C$4"
        sRefersTo = "=TestSheet!$G$54"
    Case "=Templates!$C$5"
        sRefersTo = "=TestSheet!$G$55"
    Case "=Templates!$C$6"
        sRefersTo = "=TestSheet!$G$56"
    Case "=Templates!$C$7"
        sRefersTo = "=TestSheet!$G$57"
    Case "=Templates!$C$8"
        sRefersTo = "=TestSheet!$G$58"
    Case "=Templates!$C$9"
        sRefersTo = "=TestSheet!$G$59"
    Case "=Templates!$C$10"
        sRefersTo = "=TestSheet!$G$60"

End Select

End Sub

【讨论】：

感谢您的建议。这应该可行，但考虑到我的目标表已设置并且具有定义的命名范围并且不会移动，我希望有更多动态的东西。执行类似“n + 1”类型的交易，获取每个命名单元格，并通过 1 行、1 列或 4 列更改该名称的地址，即使取决于目标表的位置。如果这有意义？

【参考方案2】：

问题是“RefersTo”是一个字符串，替换工作表名称很简单，但调整单元格地址不是。

所以我认为您最好的选择是改变方法并从头开始构建 newAddress 字符串。对于每个命名单元格，您必须做一些数学运算来确定（col，row）相对于源表的位置。然后将这些相对坐标应用于目标表，以获取新工作表中的绝对值 (col, row)。然后计算 newAddress 字符串。

这是在我的测试 excel 中运行的代码：

'Declare Module level variables
'Variables for target tables are defined in sub's for each target table.
Dim cellName As Name
Dim newName As String
Dim newNameVar As String
Dim newAddress As String
Dim newSheetVar
Dim oldSheetVar
Dim oldNameVar
Dim srcTable1
Dim trgTable1

Sub copyTables()

newSheetVar = "TestSheet"
oldSheetVar = "Templates"
oldNameVar = "Num0_"
srcTable1 = "TestTableTemplate"

'Call sub functions to copy tables, name cells and update functions.
copySrc1Table
'copySrc2Table
End Sub

'****there is another sub identical to this one below for copySrc2Table.
Sub copySrc1Table()

Dim isrcTable1StartingCol As Integer
Dim isrcTable1StartingRow As Integer
Dim itrgTable1StartingCol As Integer
Dim itrgTable1StartingRow As Integer
Dim iColInTable, iRowInTable As Integer

newNameVar = "Num1_"
trgTable1 = "SourceEnvTable1"
    ' get starting coordinates of target table
    itrgTable1StartingCol = Range(trgTable1).Column
    itrgTable1StartingRow = Range(trgTable1).Row
    Sheets(oldSheetVar).Select
    Range(srcTable1).Select
    ' get starting coordinates of source table
    isrcTable1StartingCol = Range(srcTable1).Column
    isrcTable1StartingRow = Range(srcTable1).Row
    Selection.Copy
    For Each cellName In ActiveWorkbook.Names
    'Find all names with common value
        If cellName.Name Like oldNameVar & "*" Then
      'Replace the common value with the update value you need
        newName = Replace(cellName.Name, oldNameVar, newNameVar)
        'newAddress = Replace(cellName.RefersTo, oldSheetVar, newSheetVar)
        'get coords of current cellName in source table
        iColInTable = cellName.RefersToRange.Column - isrcTable1StartingCol
        iRowInTable = cellName.RefersToRange.Row - isrcTable1StartingRow
        newAddress = "=" & newSheetVar & "!$" & ConvertToLetter(itrgTable1StartingCol + iColInTable) & "$" & (itrgTable1StartingRow + iRowInTable)
      'Edit the name of the name. This will change any formulas using this name as well
        ActiveWorkbook.Names.Add Name:=newName, RefersTo:=newAddress
        End If
    Next cellName
    Sheets(newSheetVar).Select
    Range(trgTable1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False

End Sub

Function ConvertToLetter(iCol As Integer) As String
   Dim iAlpha As Integer
   Dim iRemainder As Integer
   iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      ConvertToLetter = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
   End If
End Function

ConvertToLetter 函数由微软自己提供，请看here。

我的工作测试excel可以下载here。

希望这会有所帮助。