如何编写VBA宏：当F列等于"dept1"时将D列值复制到E列

需求：判断F列的值是否等于"dept1"，若满足条件则将对应行D列的值复制到E列。

原代码问题分析 #

你提供的代码存在两个核心问题：

1. 筛选目标列错误：代码中筛选的是第4列（D列），但需求是判断F列（第6列）的值；
2. 复制范围错误：直接复制了整个D2:D700区域到E列，没有仅复制符合筛选条件的行。

原代码：

Dim rng1 As Range
Set rng1 = ActiveSheet.UsedRange

With rng1
    .AutoFilter
    .AutoFilter Field:=4, Criterial:="GH"
   Range("D2:D700").Copy
    Range("E2:E700").PasteSpecial xlPasteValues
    .AutoFilter
End With

修正后的代码方案 #

方案1：使用AutoFilter筛选后复制（高效适配大数据量） #

Sub CopyDept1Data()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' 可替换为具体工作表，比如ThisWorkbook.Worksheets("Sheet1")
    
    ' 清除现有筛选状态
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    With ws.UsedRange
        ' 筛选F列（第6列）等于"dept1"的行
        .AutoFilter Field:=6, Criteria1:="dept1"
        ' 复制筛选后D列的可见单元格到对应E列
        .Columns("D").Offset(1).SpecialCells(xlCellTypeVisible).Copy
        .Columns("E").Offset(1).PasteSpecial xlPasteValues
    End With
    
    ' 清除筛选并取消复制状态
    ws.AutoFilterMode = False
    Application.CutCopyMode = False
End Sub

方案2：循环逐行判断（逻辑直观适配小数据量） #

Sub CopyDept1Data_Loop()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ' 获取F列最后一行数据的行号
    
    ' 从第2行开始遍历（假设第1行是表头）
    For i = 2 To lastRow
        If ws.Cells(i, "F").Value = "dept1" Then
            ws.Cells(i, "E").Value = ws.Cells(i, "D").Value ' 直接赋值，比复制粘贴更高效
        End If
    Next i
End Sub

补充说明 #

• 方案1通过SpecialCells(xlCellTypeVisible)精准复制筛选后的有效行，避免无效数据覆盖；
• 方案2用直接赋值替代复制粘贴，减少剪贴板占用，运行效率更优；
• 可根据实际数据量级选择方案：数据量较大时优先选方案1，小数据量选方案2更易调试。

内容的提问来源于stack exchange，提问作者Miguel Angel Quintana