优化代码

黑山上的鹰

各位老师：复制工作表到新工作簿并改名，搞了三种方式，怎么优化？请指教，谢谢！
第一种
Sub a()
Dim wb As Workbook, sht As Worksheet '复制报表工作表到新工作簿
Dim arr
Application.ScreenUpdating = False
On Error Resume Next
tim = Timer
arr = Sheets("b").Range("a1:d100")
For y = 2 To 6
x = Sheets("c").Range("a" & y)
Set Z = CreateObject("Scripting.FileSystemObject")
wbname = ThisWorkbook.Path & "\" & "rrr.xls" '新建变量名为rrr的工作簿
If Z.FileExists(wbname) Then                     '复制至已有工作簿中
Set wb = Workbooks.Open(wbname)
Else                                             '复制生成新工作簿中
Workbooks.Add
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "rrr.xls"
wbname = ThisWorkbook.Path & "\" & "rrr.xls"
Set wb = Workbooks.Open(wbname)
End If
Application.DisplayAlerts = False
For Each ws In Worksheets
  If ws.Name = x Then ws.Delete
Next
Application.DisplayAlerts = True
wb.Worksheets.Add().Name = x
wb.Sheets(x).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
ActiveWorkbook.Close True
Next
Application.ScreenUpdating = True
MsgBox "计算完毕,用时" & Format(Timer - tim, "0.00") & "秒！", 64, "【测试工具】"
End Sub

第二种：
Sub b()
Dim arr
Dim y, x, w, tim
Application.ScreenUpdating = False
tim = Timer
arr = Sheets("b").Range("a1:d100")
For y = 2 To 6
    x = Sheets("c").Range("a" & y)
    w = x
Dim wb As Workbook, sht As Worksheet '复制报表工作表到新工作簿
Set Z = CreateObject("Scripting.FileSystemObject")
wbname = ThisWorkbook.Path & "\" & "rrr.xls"   '新建变量名为因素分析表的工作簿
If Z.FileExists(wbname) Then  '复制至已有工作簿中
Set wb = Workbooks.Open(wbname)
ActiveWorkbook.Worksheets.Add().Name = x
ActiveWorkbook.Sheets(x).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
Else
ThisWorkbook.Sheets("b").Copy
   ActiveWorkbook.SaveAs wbname
   Workbooks("rrr.xls").Worksheets("b").Name = x
End If
ActiveWorkbook.Close True
Next
Application.ScreenUpdating = True
MsgBox "计算完毕,用时" & Format(Timer - tim, "0.00") & "秒！", 64, "【测试工具】"
End Sub

第三种
Sub c()
Dim arr
Dim y, x, w, tim
Application.ScreenUpdating = False
tim = Timer
For y = 2 To 6
    x = Sheets("c").Range("a" & y)
    w = x
Dim wb As Workbook, sht As Worksheet '复制报表工作表到新工作簿
Set Z = CreateObject("Scripting.FileSystemObject")
wbname = ThisWorkbook.Path & "\" & "rrr.xls"   '新建变量名为因素分析表的工作簿
If Z.FileExists(wbname) Then  '复制至已有工作簿中
Set wb = Workbooks.Open(wbname)
ThisWorkbook.Sheets("b").Copy Before:=wb.Sheets(Sheets.Count)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value  '保留单元格数值,去掉公式
Workbooks("rrr.xls").Worksheets("b").Name = x
Else
ThisWorkbook.Sheets("b").Copy
    ActiveWorkbook.SaveAs wbname
    Workbooks("rrr.xls").Worksheets("b").Name = x
End If
ActiveWorkbook.Close True
Next
Application.ScreenUpdating = True
MsgBox "计算完毕,用时" & Format(Timer - tim, "0.00") & "秒！", 64, "【测试工具】"
End Sub
新建 Microsoft Office Excel 97-2003 工作表.zip (13.23 KB, 下载次数: 2)

2020-2-25 22:19 上传

点击文件名下载附件