执行VBA代码时工作表抖动的厉害如何避免

Posted 2023-05-09

参考技术A 你是说屏幕刷新吧，关闭即可，Application.ScreenUpdating=False
记得处理完最后加上Application.ScreenUpdating=True
可以大幅提升处理速度

使用Excel VBA，如何将某一个工作表保存到新建的Excel中?

1、如下图所示，我想将桌面上第一章中的每个工作簿名称放置到工作表中。

2、新建一个工作簿，将其命名为“第一章目录”，按alt+f11组合键，打开宏界面。

3、在VBA中，单击插入按钮，点击插入菜单下的模块，即可新建模块，系统默认为模块1，当然也可以根据需要重命名。

4、使用do~~loop循环语句，在VBA中输入如下图所示代码：

5、返回名为“第一章目录”的工作簿中，按alt+f8组合键，弹出宏对话框。

6、点击宏对话框中的执行按钮，宏对话框自动关闭，代码自动执行，即第一章中的每个文件夹名称全部显示在工作表sheet1中。最后根据自己的需要调整格式。

参考技术A 代码如下：
Sub 分开存为工作薄()

Dim Sh As Worksheet
Dim Wk1 As Workbook
Dim Wk2 As Workbook
Dim iPath As String

Application.ScreenUpdating = False ‘将屏幕更新关闭
Application.DisplayAlerts = False

iPath = ThisWorkbook.Path & "\" '保存路径为当前工作簿所在路径
Set Wk1 = Workbooks.Add
Set Wk2 = Workbooks.Add
Wk1.SaveAs iPath & "部门" & ".xls"
Wk2.SaveAs iPath & "基层" & ".xls"
'将工作表分别复制到部门或基层工作薄中
For Each Sh In ThisWorkbook.Worksheets
With Sh
If .Name Like "*部门*" Then
.Copy before:=Workbooks("部门").Worksheets("sheet1")
ElseIf .Name Like "*基层*" Then
.Copy before:=Workbooks("基层").Worksheets("sheet1")
Else
MsgBox "工作表" & .Name & "不含有部门或基层"
End If
End With
Next
'删除新建工作薄时默认新建的工作表
For Each Sh In Wk1.Worksheets
With Sh
If .Name Like "*Sheet*" Then
.Delete
End If
End With
Next
For Each Sh In Wk2.Worksheets
With Sh
If .Name Like "*Sheet*" Then
.Delete
End If
End With
Next
'保存部门和基层工作薄
Wk1.Save
Wk2.Save
Wk1.Close
Wk2.Close
Set Wk1 = Nothing
Set Wk2 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
其中Application.DisplayAlerts、 Application.ScreenUpdating 语句把过程中的无必要的警告都删除了，像在删除多余的工作表时会提示“数据可能在你要删除的工作表中，请问是否要删除”等等的警告，在写程序的过程中可以写不加人，有利于了解工程是怎么运作的，但是最后还是加上这两句比较好，否则用户使用时太多的警告信息感觉不是很好。
.Copy before:=Workbooks("基层").Worksheets("sheet1")
此句是拷贝sheet到新的xls里，由于使用了with语句，前面的workbook的信息省略了，但是有copy before与copy after注意选择，具体区别自己也不是很清楚。Workbooks("基层").Worksheets("sheet1")拷贝到基层.xls的sheet1里，但是看到下面删除sheet时并没有把此表分别开，会不会出错？
以下是我自己的程序：
Set sht = newbk.Worksheets(1) '删除新建的newbk里的两个sheet，必须留一个，否则会出错
sht.Delete
Set sht = newbk.Worksheets(1)
sht.Delete
oldbk.Worksheets(sSheetName).Copy After:=newbk.Worksheets(1) '拷贝
Set sht = newbk.Worksheets(1) ’删除一个工作表，会删错么？
sht.Delete
newbk.Worksheets(1).Name = sSheetName
newbk.Save
拷贝处选用的是Worksheets(1)，本想用Worksheets(sSheetName)，但是系统出错，应该是新xls中没有此sheet，只有默认的1、2、3，所以出错。
对删除工作表的操作表示疑问，因为怕删错，Worksheets(1）是选择当前最前端的窗口，此程序测试正确，那么应该是新生成的没有作为active？
===============================================
所以拷贝时有3个问题：
1、copy before 与copy after的区别？
2、copy后新的名称是什么？
3、copy后的表是不是最前端的？

从网上看到的，可以对第一个问题很好的解释：
Sheets("mainREPORT").Copy Before:=Sheets(4)
after：是将表mainreport创建拷贝到‘4’表的后面
before：是将表mainreport创建拷贝到‘4’表的前面
是一个位置的问题