如何编写Excel VBA宏实现基于单元格值提取的循环复制粘贴与偏移操作

VBA实现代码（适配25000+行数据优化版） #

直接操作单元格会严重拖慢运行速度，以下代码采用数组批量读写，25000行数据跑完预计不超过10秒：

Sub 按列号分配数据()
    Dim wsOne As Worksheet, wsTwo As Worksheet
    Dim lastRow As Long, maxCol As Long
    Dim arrSource As Variant, arrTarget As Variant
    Dim i As Long, j As Long, colNum As Long
    Dim splitStr As Variant
    
    ' 绑定工作表，避免频繁切换
    Set wsOne = ThisWorkbook.Worksheets("STEP ONE")
    Set wsTwo = ThisWorkbook.Worksheets("STEP TWO")
    
    ' 判断B1是否为空，为空直接退出
    If wsOne.Range("B1") = "" Then Exit Sub
    
    ' 获取STEP ONE表最大行号和最大列号
    lastRow = wsOne.Cells(wsOne.Rows.Count, "A").End(xlUp).Row
    maxCol = wsOne.Cells(1, wsOne.Columns.Count).End(xlToLeft).Column
    
    ' 把源数据全部读入数组，避免反复交互单元格
    arrSource = wsOne.Range(wsOne.Cells(1, 2), wsOne.Cells(lastRow, maxCol)).Value
    
    ' 初始化目标数组，219列覆盖需求上限
    ReDim arrTarget(1 To lastRow, 1 To 219)
    
    ' 遍历数组处理每一行每一列
    For i = 1 To lastRow
        For j = 1 To UBound(arrSource, 2)
            ' 单元格为空直接跳转至下一行
            If arrSource(i, j) = "" Then Exit For
            
            ' 提取列号：分割字符串取第一个分号前的内容转数字
            splitStr = Split(arrSource(i, j), ";")
            If IsNumeric(splitStr(0)) Then
                colNum = CLng(splitStr(0))
                ' 列号在有效范围内就写入目标数组对应位置
                If colNum >= 1 And colNum <= 219 Then
                    arrTarget(i, colNum) = arrSource(i, j)
                End If
            End If
        Next j
    Next i
    
    ' 批量写入STEP TWO表，从G列（第7列）开始对应列号1的位置
    wsTwo.Range("G1").Resize(lastRow, 219).Value = arrTarget
    
    ' 释放对象
    Set wsOne = Nothing
    Set wsTwo = Nothing
End Sub

使用注意事项 #

• 运行前请先备份原始文件，避免数据覆盖出错
• 如果实际最大列数超过219，可修改代码中ReDim arrTarget(1 To lastRow, 1 To 219)里的219为实际最大列号
• 如果首组数据带左大括号（比如内容为{1;$6.00），可在splitStr = Split(arrSource(i, j), ";")前加一行arrSource(i,j) = Replace(arrSource(i,j),"{","")去掉大括号即可

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