多条件筛选并复制唯一值至其他工作表的VBA实现求助

修改思路 #

1. 加入多条件判断逻辑：同时满足D列为India或France、C列日期晚于2020年6月1日
2. 使用**字典（Dictionary）**记录已复制的行，确保仅复制唯一值
3. 优化代码效率，减少对工作表的重复操作

完整代码 #

Public Sub ConditionalUniqueRowCopy()
    ' 声明对象变量
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim cell As Range
    Dim uniqueDict As Object ' 用于存储唯一行的字典

    ' 声明其他变量
    Dim sourceLastRow As Long
    Dim targetLastRow As Long
    Dim rowKey As String
    Dim i As Integer
    
    ' 初始化字典
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    ' 设定源表和目标表引用
    Set sourceSheet = Workbooks("Bookcopy.xlsm").Worksheets("copy")
    Set targetSheet = Workbooks("Bookpaste.xlsm").Worksheets("paste")

    ' 获取源表D列最后一行行号
    sourceLastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
    
    ' 遍历源表D列数据（从第2行开始，跳过表头）
    For Each cell In sourceSheet.Range("D2:D" & sourceLastRow).Cells
        ' 多条件判断：D列是India/France，且C列日期>2020-06-01
        If (cell.Value = "India" Or cell.Value = "France") And _
           IsDate(sourceSheet.Cells(cell.Row, "C").Value) And _
           sourceSheet.Cells(cell.Row, "C").Value > DateSerial(2020, 6, 1) Then
           
            ' 生成当前行的唯一标识（拼接整行内容作为键，可根据实际调整主键列）
            rowKey = ""
            For i = 1 To sourceSheet.UsedRange.Columns.Count
                rowKey = rowKey & "|" & sourceSheet.Cells(cell.Row, i).Value
            Next i
            
            ' 如果字典中没有这个行的标识，说明是唯一行，执行复制
            If Not uniqueDict.Exists(rowKey) Then
                uniqueDict.Add rowKey, cell.Row ' 将行标识加入字典
                ' 获取目标表最后一行，复制整行
                targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
                cell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetLastRow + 1)
            End If
        End If
    Next cell
    
    ' 释放对象
    Set uniqueDict = Nothing
    Set sourceSheet = Nothing
    Set targetSheet = Nothing
End Sub

关键代码解释 #

• 字典去重：通过拼接当前行所有单元格内容生成唯一键，确保重复行不会被多次复制；如果你的数据有唯一主键（比如A列是ID），可以直接用主键作为键，效率更高
• 多条件判断：
  • IsDate(sourceSheet.Cells(cell.Row, "C").Value)：先判断C列内容是否为日期格式，避免非日期值导致错误
  • DateSerial(2020, 6, 1)：生成标准日期值，确保和C列日期正确比较
• 跳过表头：遍历从第2行开始，避免复制表头行

注意事项 #

1. 如果编译时提示字典相关错误，需手动引用Microsoft Scripting Runtime：打开VBA编辑器 → 工具 → 引用 → 勾选Microsoft Scripting Runtime
2. 确保Bookcopy.xlsm和Bookpaste.xlsm已打开，或者修改路径为完整文件路径（比如Workbooks("C:\Files\Bookcopy.xlsm")）
3. 若只需复制特定列而非整行，可替换cell.EntireRow.Copy为指定列范围的复制，比如sourceSheet.Range("A" & cell.Row & ":Z" & cell.Row).Copy

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