跨工作表复制行并调整列顺序：优化代码与无空行复制咨询

我来帮你优化这段VBA代码，解决运行速度慢和目标表有空行的问题～

原代码的问题分析 #

你的代码之所以运行慢，核心原因是逐单元格执行Copy操作——每一次Copy都会触发Excel的界面交互和刷新，循环次数多了自然卡顿。另外，你直接用源表的行号Zeile作为目标行号，会导致不符合条件的行对应的位置留空，这就是目标表出现空行的原因。

优化方案：内存数组+列映射+计数器控制 #

核心思路 #

1. 用数组定义列对应关系：把源列和目标列的映射整理成数组，后续修改列对应关系只需调整数组，维护更方便
2. 内存数组批量处理：一次性把源表数据读到内存数组里，处理完后再一次性写入目标表，彻底减少和Excel工作表的交互次数，速度会提升好几倍
3. 计数器控制目标行：用独立的计数器记录目标表的写入行号，确保符合条件的数据连续写入，不会留空行

优化后的完整代码 #

Sub KopieZeilenUmkehren_optimized()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim sourceData As Variant, targetData As Variant
    Dim colMap As Variant ' 存储源列到目标列的映射：(源列索引, 目标列索引)
    Dim Zeile As Long, targetRow As Long
    Dim lastRow As Long, validRowCount As Long
    
    ' 初始化工作表对象
    Set wsSource = ThisWorkbook.Sheets("Artikel")
    Set wsTarget = ThisWorkbook.Sheets("ArtikelNeu")
    
    ' 定义列映射：源列(1=A,2=B...) -> 目标列(5=E,12=L...)
    colMap = Array( _
        Array(1, 5), Array(2, 12), Array(3, 10), Array(4, 9), Array(5, 8), _
        Array(6, 7), Array(7, 6), Array(8, 1), Array(9, 4), Array(10, 3), _
        Array(11, 2), Array(12, 11) _
    )
    
    ' 获取源表最后一行，读取数据到内存数组（从第2行开始，对应原代码的循环起始行）
    lastRow = wsSource.UsedRange.Rows.Count
    sourceData = wsSource.Range("A2:L" & lastRow).Value
    
    ' 先统计符合条件的行数，避免数组空间浪费
    validRowCount = 0
    For Zeile = 1 To UBound(sourceData, 1)
        If sourceData(Zeile, 1) = "Ja" Then
            validRowCount = validRowCount + 1
        End If
    Next Zeile
    If validRowCount = 0 Then Exit Sub ' 没有符合条件的数据，直接退出
    
    ' 初始化目标数组
    ReDim targetData(1 To validRowCount, 1 To 12) ' 12对应源表的A-L列
    targetRow = 1
    
    ' 遍历源数据，填充目标数组
    For Zeile = 1 To UBound(sourceData, 1)
        If sourceData(Zeile, 1) = "Ja" Then
            Dim i As Long
            For i = 0 To UBound(colMap)
                Dim sourceCol As Long, targetCol As Long
                sourceCol = colMap(i)(0)
                targetCol = colMap(i)(1)
                targetData(targetRow, targetCol) = sourceData(Zeile, sourceCol)
            Next i
            targetRow = targetRow + 1
        End If
    Next Zeile
    
    ' 一次性写入目标表（从A1开始，可根据需求调整起始位置）
    wsTarget.Range("A1").Resize(validRowCount, 12).Value = targetData
    
    ' 可选：清空目标表中超出数据范围的旧内容
    wsTarget.Range("A" & validRowCount + 1 & ":L" & wsTarget.UsedRange.Rows.Count).ClearContents
End Sub

额外提速小技巧 #

如果你的数据量特别大，可以在代码开头加上这两行，关闭Excel的界面刷新和自动计算，进一步减少运行时间：

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

然后在代码结尾加上：

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

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