【无标题】

VBA批量复制Excel工作表

工作时，经常需要制作多个工作表，手动操作费时费力，尝试VBA代码帮你快速完成工作。

1、复制单个工作表到指定工作表前面或后面，代码如下：

Sheets("Sheet1").Copy After:=Sheets("Sheet2")    '复制工作表Sheet1到Sheet2后面

Sheets("Sheet1").Copy Before:=Sheets("Sheet2")   '复制工作表Sheet1到Sheet2前面

2、利用For循环，批量复制单张工作表到指定工作表前面或后面，代码如下：

    Dim i As Integer

    For i = 0 To 5

         Sheets("Sheet1").Copy After:=Sheets("Sheet1")    '复制工作表Sheet1到Sheet1后面

         'Sheets("Sheet1").Copy Before:=Sheets("Sheet2")   '复制工作表Sheet1到Sheet2前面

    Next

结果是复制6次，效果如下图：

3、复制指定工作表，重命名后放在指定位置。复制工作表“Sheet1”，将复制后的工作表重命名为“Sheet2”并入在工作表最后，代码如下：

   Dim Sheets As Worksheet

    Dim MSheetName As String

    Dim YSheetName As String

    YSheetName = "Sheet1"   '确定源工作表名称

    MSheetName = "Sheet2"   '确定目标工作表名称

    Dim i As Integer  '定义变量，判断是否有目标工作表名称时用

    i = 0

    Dim NewCopySheet As Worksheet

    'Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

    For Each Sheets In Worksheets

       If Sheets.Name = MSheetName Then  '先判断是否有目标工作表名称，若有提示重新修改目标工作表名字。

         MsgBox ("已有工作表" & "请修改工作表名")

         i = 1

         Exit For

        End If

     Next

    If i <> 1 Then    '没有重复工作表名称，复制工作表并命名。前提应确保有源工作表“Sheet1”

      Worksheets(YSheetName).Copy After:=Worksheets(ThisWorkbook.Sheets.Count - 3)

      Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

      NewCopySheet.Name = MSheetName

    End If

   Application.DisplayAlerts = True

可以更改这行代码将目标工作表放在指定位置Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)，放在倒数第二位Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count-1)，放倒数第三位Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count-2)，以此类推。

4、批量复制单张工作表并重命名。多次复制工作表“Sheet4”，将复制后的工作表重命名名称以数组列示Array("Sheet11", "Sheet12", "Sheet13", "Sheet14", "Sheet15")，复制后工作表放在最后，代码如下：

    Dim Sheets As Worksheet

    Dim MSheetName() As Variant

    Dim YSheetName As String

    Dim MSheetNameLength As Integer

    Dim i As Integer

    i = 0

    MSheetName = Array("Sheet11", "Sheet12", "Sheet13", "Sheet14", "Sheet15") '确定复制后工作表重命名名称

    YSheetName = "Sheet4"   '确定源目标工作表名称

    Dim j As Integer  '定义变量，判断是否有目标工作表名称时用

    Dim NewCopySheet As Worksheet

    MSheetNameLength = (UBound(MSheetName) - LBound(MSheetName) + 1)  '计算目标工作表数组长度

   For j = 0 To MSheetNameLength - 1

     For Each Sheets In Worksheets

      If Sheets.Name = MSheetName(j) Then  '先判断是否有目标工作表名称，若有提示重新修改目标工作表名字。

        MsgBox ("已有工作表" & MSheetName(j) & "，请修改工作表名")

        i = 1

        Exit Function

      End If

     Next

    Next

    If i <> 1 Then    '没有重复工作表名称，复制工作表并命名。前提应确保有源工作表

      For j = 0 To MSheetNameLength - 1

        Worksheets(YSheetName).Copy After:=Worksheets(ThisWorkbook.Sheets.Count)

        Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        NewCopySheet.Name = MSheetName(j)

       Next

    End If

   Application.DisplayAlerts = True

    5、复制多张工作表并重命名。源工作表名称数组Array("Sheet11", "Sheet12", "Sheet13", "Sheet14", "Sheet15")，目标工作表名称数组Array("Sheet21", "Sheet22", "Sheet23", "Sheet24", "Sheet25")，复制源工作表名并重命名对应数组位置。代码如下：

    Dim Sheets As Worksheet

    Dim MSheetName() As Variant

    Dim YSheetName() As Variant

    Dim MSheetNameLength As Integer

    Dim i As Integer

    i = 0

    MSheetName = Array("Sheet21", "Sheet22", "Sheet23", "Sheet24", "Sheet25")   '确定源工作表名称

    YSheetName = Array("Sheet1", "Sheet37", "Sheet38", "Sheet39", "Sheet40")   '确定目标工作表名称

    Dim j As Integer  '定义变量，判断是否有目标工作表名称时用

    Dim NewCopySheet As Worksheet

    MSheetNameLength = (UBound(MSheetName) - LBound(MSheetName) + 1)  '计算目标工作表数组长度

   For j = 0 To MSheetNameLength - 1

     For Each Sheets In Worksheets

      If Sheets.Name = MSheetName(j) Then  '先判断是否有目标工作表名称，若有提示重新修改目标工作表名字。

        MsgBox ("已有工作表" & MSheetName(j) & "，请修改工作表名")

        i = 1

        Exit Function

      End If

     Next

    Next

   

    If i <> 1 Then    '没有重复工作表名称，复制工作表并命名。前提应确保有源工作表

      For j = 0 To MSheetNameLength - 1

        Worksheets(YSheetName(j)).Copy After:=Worksheets(ThisWorkbook.Sheets.Count)

        Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        NewCopySheet.Name = MSheetName(j)

       Next

    End If

   Application.DisplayAlerts = True

6、将源工作表和复制并重命名后的工作表名称列在Excel表格内，通过提取数据并复制重命名。源工作表名称和复制后重命名的工作表名称放在EXCEL表格A、B例中，遍历源工作表和目标工作表名称并分别放入数组，复制工作表的同时重命名对应的名称。代码如下：

    Dim Sheets As Worksheet

    Dim SheetActive As Worksheet

    Dim MSheetName() As Variant

    Dim YSheetName() As Variant

    Dim SheetYName As String

    Dim SheetMName As String

    Dim Numb As Integer

    Dim MSheetNameLength As Integer

    Dim SheetA As Integer

    Set SheetActive = ActiveSheet  '确定活动单元格名称

    SheetA = SheetActive.Cells(Rows.Count, 1).End(xlUp).Row

    Dim i, k As Integer

    i = 0

    k = 0

    ReDim YSheetName(SheetA)

      For Numb = 2 To SheetA '活动工作表第2行开始，遍历第一列工作表名称

        SheetYName = SheetActive.Cells(Numb, 1).Value

        SheetMName = SheetActive.Cells(Numb, 2).Value

       '工作表名强制转换为字符串类型

       If SheetYName <> "" And SheetMName <> "" Then          '将源工作表和目标工作表名称放入数组，先计算数组长度

         k = k + 1

       End If

      Next

   

    ReDim YSheetName(k)            '重新定义源工作表和目标工作表数组长度

    ReDim MSheetName(k)

      For Numb = 2 To SheetA '活动工作表第2行开始，遍历第一列工作表名称，为数组赋值

        SheetYName = SheetActive.Cells(Numb, 1).Value

        SheetMName = SheetActive.Cells(Numb, 2).Value

       '工作表名强制转换为字符串类型

       If SheetYName <> "" And SheetMName <> "" Then

         MSheetName(l) = SheetMName

         YSheetName(l) = SheetYName

         l = l + 1                          '数组增加一个，l加1，最后会导致数组总数l比数组长度大1。

       End If

      Next

    Dim j As Integer  '定义变量，判断是否有目标工作表名称相同名称

    Dim NewCopySheet As Worksheet

    MSheetNameLength = (UBound(MSheetName) - LBound(MSheetName) + 1) '计算目标工作表数组长度

   For j = 0 To MSheetNameLength - 2          'l多1，多减去1

     For Each Sheets In Worksheets

      If Sheets.Name = MSheetName(j) Then     '先判断是否有目标工作表名称，若有提示重新修改目标工作表名字。

        MsgBox ("已有工作表" & MSheetName(j) & "，请修改工作表名")

        i = 1

        Exit Function

      End If

     Next

    Next

    If i <> 1 Then    '没有重复工作表名称，复制工作表并命名。前提应确保有源工作表

      For j = 0 To MSheetNameLength - 2

        Worksheets(YSheetName(j)).Copy After:=Worksheets(ThisWorkbook.Sheets.Count)

        Set NewCopySheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        NewCopySheet.Name = MSheetName(j)

       Next

    End If

   Application.DisplayAlerts = True