在VBA中将数据存入动态数组并拆分字符串为键值对处理Excel数据

需求说明 #

• 需将Excel原始数据中的「CTP Parameters」行内容拆分为独立的键值对行
• 部件号未发生变更时，该行的其他关联信息需在所有拆分出的键值对行中保持一致

现有代码问题 #

你提供的代码仅实现了CTP Parameters字符串的拆分与键值对写入，但未处理部件号等关联信息的复用，且直接逐单元格写入效率较低。以下是结合动态数组优化后的完整代码：

Sub SplitKeyPairsWithDynamicArray()
    Dim ws As Worksheet
    Dim lastRow As Long, outputRow As Long
    Dim baseInfo(1 To 5) As Variant ' 假设基础信息占A-E列，可根据实际调整数量
    Dim ctpStr As String, keyPairs() As String, kp() As String
    Dim outputArr() As Variant
    Dim i As Long, k As Long
    
    ' 设置操作工作表，可根据实际修改表名
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 获取数据最后一行
    outputRow = 1 ' 输出数组的起始行索引
    
    ' 初始化动态数组，预估最大行数（原始行数*平均键值对数量，可按需调整）
    ReDim outputArr(1 To lastRow * 10, 1 To 7) ' 假设最终输出7列：A-E基础列 + 键列 + 值列
    
    ' 遍历原始数据行
    For i = 2 To lastRow
        ' 读取当前行的基础信息（部件号等）
        baseInfo(1) = ws.Cells(i, "A").Value
        baseInfo(2) = ws.Cells(i, "B").Value
        baseInfo(3) = ws.Cells(i, "C").Value
        baseInfo(4) = ws.Cells(i, "D").Value
        baseInfo(5) = ws.Cells(i, "E").Value
        
        ' 获取CTP Parameters字符串
        ctpStr = ws.Cells(i, "F").Value
        ' 按~拆分键值对
        keyPairs = Split(ctpStr, "~")
        
        ' 遍历每个键值对
        For k = LBound(keyPairs) To UBound(keyPairs)
            If Trim(keyPairs(k)) <> "" Then ' 跳过空字符串
                ' 按^拆分键和值
                kp = Split(keyPairs(k), "^")
                If UBound(kp) >= 1 Then ' 确保拆分出键和值
                    ' 将基础信息写入输出数组
                    outputArr(outputRow, 1) = baseInfo(1)
                    outputArr(outputRow, 2) = baseInfo(2)
                    outputArr(outputRow, 3) = baseInfo(3)
                    outputArr(outputRow, 4) = baseInfo(4)
                    outputArr(outputRow, 5) = baseInfo(5)
                    ' 写入键和值
                    outputArr(outputRow, 6) = kp(0)
                    outputArr(outputRow, 7) = Replace(kp(1), "~", "")
                    outputRow = outputRow + 1
                End If
            End If
        Next k
    Next i
    
    ' 调整数组大小为实际使用的行数
    ReDim Preserve outputArr(1 To outputRow - 1, 1 To 7)
    
    ' 将数组一次性写入工作表（假设从A2开始输出，可修改起始位置）
    ws.Range("A2").Resize(UBound(outputArr, 1), UBound(outputArr, 2)).Value = outputArr
End Sub

关键优化点 #

• 动态数组存储：用outputArr()批量存储所有格式化后的数据，减少单元格读写操作，大幅提升运行效率
• 基础信息复用：读取每行的部件号等关联信息，在拆分出的每个键值对行中重复写入
• 边界处理：增加空字符串和拆分失败的判断，避免运行报错
• 批量写入：最后一次性将数组内容写入工作表，比逐行写入高效得多

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