如何用数组优化Excel VBA拆分多人员分配行的效率？

我有从Microsoft Planner导入的约3000行数据。在“Assigned to”列中，部分行包含类似“Employee A; Employee B; Employee C”的字符串，需将这类行拆分为每行对应一个人员的形式（如示例中的三行），其他列内容保持不变。当前使用的VBA代码处理需2-3分钟，处理后从3000行变为7000行。现有代码如下：

'=================================
'How many rows have multiple employees assigned?
'=================================
lNbLignes = tbl1lpEmploye.ListColumns("Nom du compartiment").DataBodyRange.End(xlDown).Row 'Total number of rows
iColonne = tbl1lpEmploye.ListColumns("Assigned to").DataBodyRange.Column 'Column that contains the assignments

iCompteur = 0
'Count the number of rows that contain ";" in "Assigned to" and thus need to be duplicated
For I = 2 To lNbLignes
    If InStr(ws1lpEmploye.Cells(I, iColonne).Value, ";") <> 0 Then
        iCompteur = iCompteur + (Len(ws1lpEmploye.Cells(I, iColonne).Value) - Len(Replace(ws1lpEmploye.Cells(I, iColonne).Value, ";", "")))
    End If
Next I

'=================================
'Duplicate rows with multiples assignments
'=================================
iColonne = tbl1lpEmploye.ListColumns("Assigned to").DataBodyRange.Column
    
For I = 2 To (lNbLignes + iCompteur) 'Number of rows + number of rows with ";" in "Assigned to"
    iPosition = InStr(ws1lpEmploye.Cells(I, iColonne).Value, ";") '"Employee A; Employee B; Employee C"
    If iPosition <> 0 Then
        With ws1lpEmploye
            .Rows(I + 1).Insert 'Add a news row
            .Cells(I + 1, iColonne).Value2 = Mid(.Cells(I, iColonne).Value2, iPosition + 1) 'Add the name following the character ";" in the new row I+1
            .Cells(I, iColonne).Value2 = Left(.Cells(I, iColonne).Value2, iPosition - 1) 'Keep the previous name in row I
            'At this point, RowI: "Employee A"
            'Row I+1: "Employee B;Employee C". The loop will continue at I+1, so the next lines that will be looked at is this one
            For j = 1 To tbl1lpEmploye.ListColumns.Count 'Copy the content of every other column in I+1
                Select Case j
                    Case iColonne
                        'Don't do anything to the "Assigned to" column
                    Case Else
                        .Cells(I + 1, j).Value2 = .Cells(I, j).Value2 '
                End Select
             Next j
        End With
    End If
Next I

请问能否通过数组处理后再写入原Excel表格，以提升处理速度？

当然可以用数组处理来大幅提升速度——原代码慢的核心原因是频繁操作工作表单元格/插入行，这是VBA中效率最低的操作之一。数组处理是把所有数据一次性读入内存，在内存中完成拆分逻辑，最后一次性写回工作表，能把处理时间压缩到几秒甚至更短。

以下是优化后的数组版代码：

Sub SplitAssignedToArray()
    Dim tbl As ListObject
    Dim srcArr As Variant, destArr As Variant
    Dim assignedCol As Integer, totalCols As Integer
    Dim i As Long, j As Integer, k As Long
    Dim assignedNames As Variant, name As Variant
    
    ' 设置表格对象（替换为你的实际表格名称）
    Set tbl = ThisWorkbook.Worksheets("ws1lpEmploye").ListObjects("tbl1lpEmploye")
    assignedCol = tbl.ListColumns("Assigned to").Index ' 获取"Assigned to"列的索引（从1开始）
    totalCols = tbl.ListColumns.Count
    
    ' 将表格数据读入源数组（包含表头）
    srcArr = tbl.DataBodyRange.Value
    
    ' 第一步：计算目标数组的总行数
    Dim totalRows As Long
    totalRows = 0
    For i = LBound(srcArr, 1) To UBound(srcArr, 1)
        ' 按分号拆分，统计每个单元格对应的行数
        assignedNames = Split(Trim(srcArr(i, assignedCol)), ";")
        totalRows = totalRows + UBound(assignedNames) + 1
    Next i
    
    ' 初始化目标数组
    ReDim destArr(1 To totalRows, 1 To totalCols)
    k = 1 ' 目标数组的行指针
    
    ' 第二步：遍历源数组，拆分并填充目标数组
    For i = LBound(srcArr, 1) To UBound(srcArr, 1)
        assignedNames = Split(Trim(srcArr(i, assignedCol)), ";")
        ' 遍历拆分后的每个人员名称
        For Each name In assignedNames
            ' 复制当前行的所有列内容
            For j = 1 To totalCols
                If j = assignedCol Then
                    destArr(k, j) = Trim(name) ' 去除名称前后的空格
                Else
                    destArr(k, j) = srcArr(i, j)
                End If
            Next j
            k = k + 1
        Next name
    Next i
    
    ' 第三步：清空原表格数据，写入新数据
    With tbl
        .DataBodyRange.Delete ' 删除原有数据行
        ' 插入足够的行并写入数组数据
        .ListRows.Add Count:=totalRows
        .DataBodyRange.Value = destArr
    End With
    
    MsgBox "数据拆分完成！处理后共" & totalRows & "行", vbInformation
End Sub

优化点说明 #

• 内存中处理：所有数据读写都在数组中完成，避免了原代码中逐行插入、逐个单元格赋值的低效操作。
• 减少工作表交互：仅在开始和结束时各进行一次数据读写，把工作表操作降到最少。
• 逻辑简化：直接拆分每个单元格的人员列表，一次性生成所有目标行，无需循环处理插入后的行。
• 自动处理空格：用Trim()去除拆分后名称前后的空格，避免出现" Employee B"这类带空格的无效名称。

使用注意事项 #

1. 确保代码中的工作表名称"ws1lpEmploye"和表格名称"tbl1lpEmploye"与你的实际文件一致。
2. 如果表格包含公式，原代码会保留值，数组处理同样会保留原单元格的值（而非公式），如果需要保留公式可以调整代码逻辑。
3. 处理前建议备份数据，避免意外情况。

内容的提问来源于stack exchange，提问作者EBassal