如何优化VBA复制粘贴代码，实现多条件分区域批量输出？

需求说明 #

• 根据Sheet1中E列的单元格值，将指定行的5列特定数据（E、D、F、G、H列）导出到Sheet2
• Sheet1包含20余列，仅需提取上述5列
• 当前代码重复编写复制逻辑，需优化为通用逻辑，支持多条件下在Sheet2生成多个列固定、行数可变的偏移表格

现有代码 #

For myRow = 1 To LastRow

If (Sheets("Sheet1").Cells(myRow, "E") = "TI002768E2XA E005") Then
    Set srcRange = Sheets("Sheet1").Cells(myRow, "F").Resize(1, 5)
    If Application.CountA(srcRange) = 5 Then
        Sheets("Sheet2").Cells(myCopyRow, "B") = Sheets("Sheet1").Cells(myRow, "E")
        Sheets("Sheet2").Cells(myCopyRow, "C") = Sheets("Sheet1").Cells(myRow, "D")
        Sheets("Sheet2").Cells(myCopyRow, "D") = Sheets("Sheet1").Cells(myRow, "F")
        Sheets("Sheet2").Cells(myCopyRow, "E") = Sheets("Sheet1").Cells(myRow, "G")
        Sheets("Sheet2").Cells(myCopyRow, "F") = Sheets("Sheet1").Cells(myRow, "H")
        myCopyRow = myCopyRow + 1
    
    End If
    
End If 
If (Sheets("Sheet1").Cells(myRow, "E") = "TI002768E2XA E105") Then
    Set srcRange = Sheets("Sheet1").Cells(myRow, "F").Resize(1, 5)
    If Application.CountA(srcRange) = 5 Then
        Sheets("Sheet2").Cells(myCopyRow1, "H") = Sheets("Sheet1").Cells(myRow, "E")
        Sheets("Sheet2").Cells(myCopyRow1, "I") = Sheets("Sheet1").Cells(myRow, "D")
        Sheets("Sheet2").Cells(myCopyRow1, "J") = Sheets("Sheet1").Cells(myRow, "F")
        Sheets("Sheet2").Cells(myCopyRow1, "K") = Sheets("Sheet1").Cells(myRow, "G")
        Sheets("Sheet2").Cells(myCopyRow1, "L") = Sheets("Sheet1").Cells(myRow, "H")
        myCopyRow1 = myCopyRow1 + 1
    
    End If
    
End If

Next myRow

优化方案 #

核心思路 #

通过配置化映射+通用复制函数，把重复的复制逻辑封装，新增条件时只需修改配置，无需重复编写代码。

优化后代码 #

Sub ExportToSheet2()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, myRow As Long
    Dim conditionMap As Object ' 存储条件与目标列的映射
    Dim targetCol As Variant, currentRow As Long
    Dim srcRange As Range
    
    ' 初始化工作表对象
    Set wsSrc = ThisWorkbook.Sheets("Sheet1")
    Set wsDest = ThisWorkbook.Sheets("Sheet2")
    Set conditionMap = CreateObject("Scripting.Dictionary")
    
    ' 配置条件：Key=E列匹配值，Value=Sheet2起始列（字母）
    conditionMap("TI002768E2XA E005") = "B"
    conditionMap("TI002768E2XA E105") = "H"
    ' 新增条件直接在这里添加，比如：conditionMap("新条件值") = "N"
    
    ' 初始化每个条件的目标起始行（默认从第1行开始，可根据需求修改）
    Dim rowCounters As Object
    Set rowCounters = CreateObject("Scripting.Dictionary")
    For Each targetCol In conditionMap.Values
        rowCounters(targetCol) = 1
    Next targetCol
    
    ' 获取Sheet1最后一行
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "E").End(xlUp).Row
    
    ' 遍历Sheet1行
    For myRow = 1 To lastRow
        ' 检查当前行E列值是否在配置中
        If conditionMap.Exists(wsSrc.Cells(myRow, "E").Value) Then
            Set srcRange = wsSrc.Cells(myRow, "F").Resize(1, 5)
            ' 验证F-H列是否非空
            If Application.CountA(srcRange) = 5 Then
                targetCol = conditionMap(wsSrc.Cells(myRow, "E").Value)
                currentRow = rowCounters(targetCol)
                
                ' 执行通用复制逻辑
                With wsDest
                    .Cells(currentRow, targetCol).Value = wsSrc.Cells(myRow, "E").Value
                    .Cells(currentRow, targetCol).Offset(0, 1).Value = wsSrc.Cells(myRow, "D").Value
                    .Cells(currentRow, targetCol).Offset(0, 2).Value = wsSrc.Cells(myRow, "F").Value
                    .Cells(currentRow, targetCol).Offset(0, 3).Value = wsSrc.Cells(myRow, "G").Value
                    .Cells(currentRow, targetCol).Offset(0, 4).Value = wsSrc.Cells(myRow, "H").Value
                End With
                
                ' 更新对应条件的目标行计数器
                rowCounters(targetCol) = currentRow + 1
            End If
        End If
    Next myRow
    
    ' 释放对象
    Set wsSrc = Nothing
    Set wsDest = Nothing
    Set conditionMap = Nothing
    Set rowCounters = Nothing
End Sub

优化亮点 #

1. 配置化管理：新增匹配条件时，只需在conditionMap中添加键值对，无需修改核心复制逻辑
2. 通用复制逻辑：用Offset方法替代硬编码列号，避免重复编写5列赋值代码
3. 统一计数器管理：用字典存储每个条件的目标行计数器，避免多个独立变量（如myCopyRow、myCopyRow1）的混乱
4. 对象化操作：提前定义工作表对象，减少重复调用Sheets("SheetX")的性能损耗

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