Excel 在同一工作表中多次复制（命名）表并更改表名

我正在构建一个项目管理电子表格，其中多个团队将有一份副本。我想创建一个简单的地址簿。我将团队的名称放在一个表中，并使用VBA创建

在范围

B4:D5

中有一个简单的表，其中有三个列名：

• 名字
• 电话
• 电子邮件

我已将此表（以Manager的名义）命名为

ContactTeam1

我想复制并粘贴这个精确的3x2表到每个对应的团队（如图像）下面，并将每个命名表更改为

ContactTeam2

，

ContactTeam3

等等

我想使用VBA的原因是，我们有许多不同的项目，所以我想尽可能地自动化这个过程，以备将来的项目使用

我将用手在表格中填写所有必要的信息（姓名、电话、电子邮件）。我之所以要使用表，是因为它可以自动展开，以包含最后一行下面的任何新行

作为额外功能，当有人单击顶部包含团队名称的单元格时。（

团队蓝色

，

团队红色

等）相应范围内的所有电子邮件都将复制到剪贴板，以便在电子邮件客户端中使用。（使用表格可以更容易地做到这一点——这是我想使用它们的另一个原因）。

我希望这能有所帮助

Sub Bouton()

    Dim cell As Range
    Dim rng As Range
    Dim cnt As Integer
    Dim RangeName As String
    Dim CellAdd1, CellAdd2 As String

    For cnt = 2 To ActiveSheet.Range("NumberTimes")

        Set rng = Range("ContactTeam" & (cnt - 1))

        RangeName = "ContactTeam" & cnt
        CellAdd1 = Cells(rng.Row, rng.Column + 3).Address
        CellAdd2 = Cells(rng.Row + 1, rng.Column + 5).Address 
        '+ 1 in the row so the named range goes from B4 to D5 

        Set cell = ActiveSheet.Range(CellAdd1, CellAdd2)
        ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=cell

        Range("ContactTeam1").Copy Range("ContactTeam" & cnt)

    Next cnt

End Sub

---

我不是VBA中的佼佼者，但它的作用是每3个单元格创建一个新范围，并将其命名为从

ContactTeam2

到您的限制。我创建了一个名为

NumberTimes

的命名范围。基本上，您可以告诉它要创建多少个新范围

最简单的，我想我们可以在这里使用字典。可能会更快，但在这里，他知道我测试/尝试的是什么，完全基于您的数据，并且有效

附属d（）

表1.选择

范围（“b3”）。选择

做

i=i+1

在我5点的时候循环

---

End Sub

您希望它与按钮关联，还是应该检测有多少个团队并复制相应的次数？请向我们展示您尝试的代码以及失败的地方。我们愿意帮助和改进，但我们不是一个代码编写服务。luisarcher，我已经有了一个子过程，它创建了工作表的第2行和第3行。此子项被指定给一个按钮，按下该子项将创建这些行。Luuklag，实际上我没有任何关于我所问问题的现有代码，只是因为我以前从未使用命名范围“复制”并重命名它们，所以我不知道从哪里开始。你好，luisarcher，谢谢你的回复。我真的很感激。正如我在问题中所问的，您的解决方案确实为每个单元格创建了命名范围，但它不会像从

B4:D5

复制表那样复制表。不管怎么说，你的解决方案实际上给了我一个方法。我马上就来！再次，非常感谢。我更改了代码，使您的两行位于命名范围内。但是，我建议您不要将列标题放在指定的范围内。I=您想继续的任何时候都可以删除-range（ActiveCell，ActiveCell.End（xlDown）.End（xlToRight））。选择

Range("b3:d4").Name = "mainteam"

 ActiveCell.Offset(0, 3).Select

Range("mainteam").Copy ActiveCell

 Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select

Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Name = "team" & i