如何优化一下这段vba代码？

Question

原始数据表格

工号 部门 姓名 实发金额 邮件地址
A001 办公室 N1 4070 [e-mail]
A002 办公室 N2 3150 [e-mail]
A003 办公室 N3 2630 [e-mail]

用VBA产生每个员工个人的工资表

Sub BatchWrite()
    Dim head,record As Range
    dim row_number as integer
    row_number = ActiveSheet.UsedRange.Rows.Count
    set head = ActiveSheet.Range("1:1")
    For i = 2 To row_number
        Set record = ActiveSheet.Range(i & ":" & i)
        call emailInfo(head,record)
    Next i
End Sub


Function emailInfo(ByVal head As Range,ByVal rng As Range) 
    Dim wb As Workbook
    Set wb = Workbooks.Add
    Dim ws As Worksheet
    Set ws = wb.Sheets(1)
    ws.Range("1:1").Value2 = head.Value2
    ws.Range("2:2").Value2 = rng.Value2
    Dim ename,filePath As String
    ename = rng(3).Value2
    filePath = "f:\" + ename + "的工资表.xlsx"
    wb.SaveAs Filename:=filePath
    wb.Close SaveChanges:=True
    Set wb = Nothing
    Set ws = Nothing    
End Function

运行达到预期，但是有不足：
屏幕总是闪烁，运行速度慢（实际上有500多行）。
请问如何优化一下这段VBA代码？

Answer 1

1.关闭屏幕更新： 在代码运行时关闭屏幕更新可以显著提高性能。
2.关闭自动计算： 在代码运行时关闭自动计算，并在代码结束后重新开启。
3.禁用事件处理： 在代码运行时禁用事件处理，并在代码结束后重新开启。

Sub BatchWrite()
    Dim head, record As Range
    Dim row_number As Integer
    Dim savedScreenUpdating As Boolean
    Dim savedCalcMode As XlCalculation
    Dim savedEnableEvents As Boolean

    ' 保存当前设置
    savedScreenUpdating = Application.ScreenUpdating
    savedCalcMode = Application.Calculation
    savedEnableEvents = Application.EnableEvents

    ' 关闭屏幕更新、自动计算和事件处理
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    row_number = ActiveSheet.UsedRange.Rows.Count
    Set head = ActiveSheet.Range("1:1")
    For i = 2 To row_number
        Set record = ActiveSheet.Range(i & ":" & i)
        Call emailInfo(head, record)
    Next i

    ' 恢复原设置
    Application.ScreenUpdating = savedScreenUpdating
    Application.Calculation = savedCalcMode
    Application.EnableEvents = savedEnableEvents
End Sub

Function emailInfo(ByVal head As Range, ByVal rng As Range)
    Dim wb As Workbook
    Set wb = Workbooks.Add
    Dim ws As Worksheet
    Set ws = wb.Sheets(1)
    ws.Range("1:1").Value2 = head.Value2
    ws.Range("2:2").Value2 = rng.Value2
    Dim ename, filePath As String
    ename = rng(3).Value2
    filePath = "f:\" & ename & "的工资表.xlsx"
    wb.SaveAs Filename:=filePath
    wb.Close SaveChanges:=True
    Set wb = Nothing
    Set ws = Nothing
End Function

Answer 2

Sub BatchWrite()

Application.ScreenUpdating = False ' 关闭屏幕更新
Application.Calculation = xlCalculationManual ' 关闭自动计算
Application.EnableEvents = False ' 禁用事件

Dim head As Range, record As Range
Dim row_number As Long
Dim i As Long
Dim startTime As Double
startTime = Timer ' 记录开始时间

row_number = ActiveSheet.UsedRange.Rows.Count
Set head = ActiveSheet.Range("1:1")

For i = 2 To row_number
    Set record = ActiveSheet.Range(i & ":" & i)
    Call emailInfo(head, record)
Next i

Application.ScreenUpdating = True ' 恢复屏幕更新
Application.Calculation = xlCalculationAutomatic ' 恢复自动计算
Application.EnableEvents = True ' 启用事件

MsgBox "处理完成！耗时：" & Round(Timer - startTime, 2) & "秒", vbInformation

End Sub

Function emailInfo(ByVal head As Range, ByVal rng As Range)

Dim wb As Workbook
Dim ws As Worksheet
Dim ename As String
Dim filePath As String

Set wb = Workbooks.Add
Set ws = wb.Sheets(1)

' 复制表头和记录
ws.Range("1:1").Value2 = head.Value2
ws.Range("2:2").Value2 = rng.Value2

' 生成文件名并保存
ename = rng.Cells(1, 3).Value2
filePath = "f:\" & ename & "的工资表.xlsx"
wb.SaveAs Filename:=filePath
wb.Close SaveChanges:=True

' 释放对象
Set ws = Nothing
Set wb = Nothing

End Function