动态创建命名单元格

时间：2013-08-21 18:01:07

标签： excel-vba excel-2010 vba excel

我有一个包含3个工作表的工作簿。一个工作表将具有输入值（此时不创建，此问题不需要），一个工作表包含多个“模板”或“源”表，最后一个工作表有4个格式化的“目标”表（空或不具有'无所谓）。每个模板表有3列，一列标识后两列中的值。值列中包含公式，每个单元格都是Named。公式使用单元格名称而不是单元格地址（例如MyData1而不是C2）。

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

这是我需要帮助的地方。我改变该地址的方式只有在我的模板和目标使用其透视图的相同单元格地址时才有效。他们不是。 （例如，Template1表具有值为B2到C10的值单元格，而我的目标表格可能是G52的G52）。底线我需要弄清楚如何使用模板复制这些名称或通过执行类似替换的操作来命名单元格，我根据目标表增加地址值＃...记住我有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

2 个答案:

答案 0 :(得分：0)

我已经更新了copySrc1Table（）过程，删除了设置newAdress的行上的find方法。我已将其替换为首先设置为源cellname.refers为value的字符串。此值将发送到一个新的子（子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

答案 1 :(得分：0)

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

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

以下是我的测试中使用的代码：

'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函数由Microsoft自己提供，查看here。

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

希望这有帮助。

相关问题
最新问题