Excel VBA 批量创建带名称的任意数量的工作表

2018-06-13 本文已影响82人懒人Excel

在这相同的问题上，之前推送了使用数据透视表批量创建工作表的教程，该方法巧妙的利用了数据透视表的「报表筛选页」功能，达到了批量创建工作表的目的。

今天接着之前的 VBA 入门教程，使用 VBA 批量创建带名称的工作表。这篇文章不再介绍编写 VBA 的一些基本操作，如需要请点击这里查看入门教程。

基本思路

写代码前，应先梳理大概的执行流程，这样有助于减少代码中的错误。以下是根据我们的目标，梳理出的 4 个步骤。

先输入要创建的工作表的名称。
从工作表中，读取名称所在区域。
为了保证顺序，规定名称区域只能为1列。
循环名称区域的每一个单元格，单元格不为空时，以单元格的值作为工作表的名称，在工作簿末尾创建工作表。

VBA 代码

直接上代码，如下所示。其中单引号（'）开头的行为注释。

Sub CreateSheets()
   '遇到错误，跳过继续执行'
   On Error Resume Next
   
   '声明创建的工作表的名称区域，并用inputbox获取
   Dim nameRange As Range
   Set nameRange = Application.InputBox(Prompt:="请选择一列名称区域", Type:=8)
   
   '判断名称区域的列数，多于1列，退出过程
   If nameRange.Columns.Count > 1 Then
       MsgBox "请选择一列名称区域"
       Exit Sub
   End If
   
   '判断名称数量，如果数量过多，退出过程
   If nameRange.Count > 1000 Then
       MsgBox "名称数量过多，请检查后再试"
       Exit Sub
   End If
   
   '循环名称区域，创建工作表
   Dim sh As Worksheet
   Dim cell As Range
   For Each cell In nameRange
       '如果单元格不为空，继续
       If cell.Value <> "" Then
           '在工作簿末尾创建工作表
           Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
           sh.name = cell.Value
       End If
   Next

End Sub

代码解释

On Error Resume Next

首先看第一行，第一行表示如果遇到错误，跳过出现错误的行，继续执行下一行。因为输入的工作表名称有可能出现不规范字符，这样出现错误，无法创建工作表。因此用这种方法直接跳过，继续创建下一个工作表。

Dim nameRange As Range
Set nameRange = Application.InputBox(Prompt:="请选择一列名称区域", Type:=8)

Application.InputBox 函数可以接受用户输入的内容，它是 VBA 内置函数，可以指定输入的内容的类型。在这里，我们指定 Type:=8，即单元格区域。把输入的区域赋值到 nameRange 变量。

If nameRange.Columns.Count > 1 Then
 MsgBox "请选择一列名称区域"
 Exit Sub
End If

这一块代码用 Range 对象 Columns 属性的 Count 方法获取区域的包含的列数。为了保证创建工作表的顺序，规定只能为一列，如果多于1列，退出过程。

If nameRange.Count > 1000 Then
 MsgBox "名称数量过多，请检查后再试"
 Exit Sub
End If

你在选择名称区域时，可能不小心会选择整列，这样单元格数量过多，导致代码执行时间很长，有可能导致 Excel 崩溃。因此在这里对名称区域的单元格数量做一个限制。

'循环名称区域，创建工作表
Dim sh As Worksheet
Dim cell As Range
For Each cell In nameRange
  '如果单元格不为空，继续
  If cell.Value <> "" Then
      '在工作簿末尾创建工作表
       Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
       sh.name = cell.Value
  End If
Next

这一块就是真正的批量创建工作表的部分了。这里用到了 For Each 循环方法，逐一循环nameRange 区域中的每一个单元格。当单元格不为空时，以单元格的值作为名称，在工作簿末尾创建工作表。

如何运行

Alt + F11 打开 VB 编辑器。
右键 VBA 工程，插入模块。
将上述代码粘贴到模块里。
关闭 VB 编辑器回到工作簿，点击开发工具→宏命令。
其中选择刚才粘贴的过程，CreateSheets，点击执行。

批量复制

上面代码批量创建了空白工作表，那么我想把现有的一个工作表复制 n 份，能实现吗？当然可以，而且在上面的代码基础上，改两行代码即可。代码如下：

Sub CopySheets()
   '遇到错误，跳过继续执行'
   On Error Resume Next
   
   '声明创建的工作表的名称区域，并用inputbox获取'
   Dim nameRange As Range
   Set nameRange = Application.InputBox(Prompt:="请选择一列名称区域", Type:=8)
   
   '判断名称区域的列数，多于1列，退出过程'
   If nameRange.Columns.Count > 1 Then
       MsgBox "请选择一列名称区域"
       Exit Sub
   End If
   
   '判断名称数量，如果数量过多，退出过程'
   If nameRange.Count > 1000 Then
       MsgBox "名称数量过多，请检查后再试"
       Exit Sub
   End If
   
   '循环名称区域，创建工作表'
   Dim cell As Range
   For Each cell In nameRange
       '如果单元格不为空，继续'
       If cell.Value <> "" Then
           '指定工作表复制到工作簿末尾'
           Worksheets("Sheet1").Copy after:=Worksheets(Worksheets.Count)
           ActiveSheet.name = cell.Value
       End If
   Next
End Sub

需要复制哪一个工作表？需要在复制操作行指定。之后再宏列表里选择 CopySheets 执行。

Worksheets("这是复制的工作表").Copy after:=Worksheets(Worksheets.Count)

image

注意事项

如果名称不符合规范，代码创建默认名称的工作表。
如果要保存代码，将工作簿另存为启用宏的工作簿。