求VBA代码：从Excel多段落单元格提取ABC:格式内容并拆分至独立行

核心优化思路 #

• 用数组批量读写替代逐单元格操作，砍掉Excel对象交互的耗时开销
• 正则精准匹配「ABC:数字串」格式，比手动遍历字符串快得多
• 一次性写入结果，减少工作表刷新次数

实现代码 #

Option Explicit
Sub ExtractABCNumbers()
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, i As Long, j As Long, resultRow As Long
    Dim sourceData As Variant, resultData As Variant
    Dim regEx As Object, matches As Object, match As Object
    Dim cellText As String
    
    ' 修改这里的工作表名，对应你的数据源表
    Set wsSource = ThisWorkbook.Worksheets("数据源")
    ' 自动创建结果表，已存在则直接使用
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("拆分结果")
    On Error GoTo 0
    If wsResult Is Nothing Then
        Set wsResult = ThisWorkbook.Worksheets.Add(After:=wsSource)
        wsResult.Name = "拆分结果"
    End If
    
    ' 把源数据一次性读到数组，比逐单元格读取快N倍
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    sourceData = wsSource.Range("A1:Z" & lastRow).Value ' 数据列范围按需调整，比如A到X列就写"A1:X"
    
    ' 初始化正则，专门匹配ABC:后跟数字串的格式
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    regEx.Pattern = "ABC:\d+" ' 若数字串包含字母，改成"ABC:[A-Za-z0-9]+"即可
    
    ' 预估结果数组大小，按每行最多10个匹配项预留，可根据实际调整倍数
    ReDim resultData(1 To lastRow * 10, 1 To UBound(sourceData, 2))
    resultRow = 1
    
    ' 先复制表头
    For j = 1 To UBound(sourceData, 2)
        resultData(resultRow, j) = sourceData(1, j)
    Next j
    resultRow = resultRow + 1
    
    ' 批量处理每一行数据
    For i = 2 To lastRow
        cellText = sourceData(i, 1) ' 目标单元格在A列，需修改则替换为对应列号（比如B列写2）
        If cellText <> "" Then
            Set matches = regEx.Execute(cellText)
            If matches.Count > 0 Then
                ' 每个匹配项单独生成一行，复制原行所有数据
                For Each match In matches
                    For j = 1 To UBound(sourceData, 2)
                        resultData(resultRow, j) = sourceData(i, j)
                    Next j
                    ' 将目标列替换为匹配到的ABC串
                    resultData(resultRow, 1) = match.Value ' 对应上面的目标列号
                    resultRow = resultRow + 1
                Next match
            Else
                ' 无匹配项时保留原行
                For j = 1 To UBound(sourceData, 2)
                    resultData(resultRow, j) = sourceData(i, j)
                Next j
                resultRow = resultRow + 1
            End If
        Else
            ' 空单元格直接保留原行
            For j = 1 To UBound(sourceData, 2)
                resultData(resultRow, j) = sourceData(i, j)
            Next j
            resultRow = resultRow + 1
        End If
    Next i
    
    ' 把结果一次性写入工作表
    wsResult.Range("A1").Resize(resultRow - 1, UBound(resultData, 2)).Value = resultData
    
    ' 清理对象释放内存
    Set regEx = Nothing
    Set matches = Nothing
    Set wsSource = Nothing
    Set wsResult = Nothing
    
    MsgBox "拆分完成！", vbInformation
End Sub

使用说明 #

1. 打开目标Excel文件，按Alt+F11打开VBA编辑器
2. 插入模块，将上述代码粘贴进去
3. 调整代码里的工作表名、数据列范围、目标单元格列号这几个关键位置
4. 运行宏，或给宏绑定一个工作表按钮，点击即可自动处理

自动触发设置（可选） #

如果需要上传数据后自动解析，给数据源表添加Worksheet_Change事件：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 假设数据在A列，只要A列有修改就自动执行拆分
    If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
        ExtractABCNumbers
    End If
End Sub

将这段代码粘贴到数据源表的代码窗口中，修改A:A为你的目标列范围即可。

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