如何批量复制sheet并按要求重新命名

sunfei00426

需要按照“表名”复制每个表，并将每个表的名字修改为需要的名字 脱贫户、监测户享受政策告知单(2024).zip (9.89 KB, 下载次数: 6)

2024-11-14 12:22 上传

点击文件名下载附件

沧海一粟123123

Sub test()
Dim arr
Dim k As Integer
Dim sh As Worksheet
Sheet1.Activate

k = Range("a65536").End(xlUp).Row
arr = Sheet1.Range("a2:a" & k)
For x = 2 To UBound(arr) - 1
    Sheet2.Copy after:=Sheets(Sheets.Count)
    ActiveSheet.Range("b2") = arr(x, 1)
    ActiveSheet.Name = arr(x, 1)
Next x
End Sub

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, i&, wks As Worksheet
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    For Each wks In Worksheets
        If wks.Name <> "表名" And wks.Name <> "模板" Then wks.Delete
    Next
    ar = Worksheets(1).[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        Worksheets("模板").Copy after:=Worksheets(Worksheets.Count)
        With ActiveSheet
            .[B2].Value = ar(i, 1)
            .Name = ar(i, 1)
        End With
    Next i
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。。。。

sunfei00426

gwjkkkkk 发表于 2024-11-14 19:51
请参考。。。。。。

膜拜大神

sunfei00426

gwjkkkkk 发表于 2024-11-14 19:49
Option Explicit
Sub TEST2()
    Dim ar, i&, wks As Worksheet

sunfei00426

沧海一粟123123 发表于 2024-11-14 12:38
Sub test()
Dim arr
Dim k As Integer

感谢感谢，感谢感谢感谢感谢感谢感谢感谢感谢