用VBA快速建立多个工作表

Sub cresheet()
' 批量新建多个sheet表，新建一个cresheet的宏
Dim a As Integer               '定义a变量
a = 2                                '初始值，从第二行开始，可以更改
Set st = Worksheets("神山")       ' 表初始值，定位源数据表，可以更改
Do While st.Cells(a, "A") <> ""   ' 设定循环条件，从神山表中的A2开始，如果数据不为空，执行该循环
On Error Resume Next            ' 若表名不存在，忽略代码引起的运行错误
If Worksheets(st.Cells(a, "A").Value) Is Nothing Then '判断是否存在对应的工作表
Worksheets.Add after:=Worksheets(Worksheets.Count)      '永远将新表加入到最后一个工作表之后
ActiveSheet.Name = st.Cells(a, "A").Value             '新的工作表为当前活动的工作，将工作表的名称更改为神山表中对应单元格的名字。
End If
a = a + 1   '行号加1，继续新增下一个
Loop
End Sub
'结束宏

这个很简单，来自互联网

不过还不是很完善，我需要的是复制某个工作表
将第9行
Worksheets.Add after:=Worksheets(Worksheets.Count)
改为
Worksheets(“666”).Copy After:=Worksheets(Worksheets.Count)
可以解决这个问题
但是运行速度很慢，不知道为啥