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