如何优化一下这段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.批量处理: 将所有数据一次性读入数组 data，然后在 emailInfo 函数中处理数组中的数据。这样可以减少对工作表的频繁访问，从而提高运行速度。

Sub BatchWrite()
    Dim head As Range
    Dim data As Variant
    Dim row_number As Integer
    row_number = ActiveSheet.UsedRange.Rows.Count
    Set head = ActiveSheet.Range("1:1")
    
    ' 关闭屏幕更新
    Application.ScreenUpdating = False
    
    ' 将数据读入数组
    data = ActiveSheet.Range("A2:E" & row_number).Value2
    
    ' 生成每个员工的工资表
    Dim i As Integer
    For i = 1 To UBound(data, 1)
        Call emailInfo(head, data, i)
    Next i
    
    ' 重新开启屏幕更新
    Application.ScreenUpdating = True
End Sub

Function emailInfo(ByVal head As Range, ByVal data As Variant, ByVal index As Integer)
    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 = Application.Index(data, index, 0)
    Dim ename, filePath As String
    ename = data(index, 3)
    filePath = "f:\" & ename & "的工资表.xlsx"
    wb.SaveAs Filename:=filePath
    wb.Close SaveChanges:=True
    Set wb = Nothing
    Set ws = Nothing
End Function