Excel VBA按产品状态复制数据至指定工作表时的重复问题及无复制执行故障排查

我来帮你梳理下为什么修改后的代码无法复制数据，以及如何修复和优化：

核心问题：Find方法的搜索值完全错误 #

你在判断Sheet3是否已有数据时，写了What:=CodeCol.Value，但CodeCol是Sheet3的整个D列范围，CodeCol.Value返回的是一个数组而非单个参考编号，这就导致Find永远找不到匹配项——更关键的是，你本来应该搜索当前遍历行的参考编号（也就是Sheet1里和Status同 row 的那个参考编号），而不是目标表的整列值。

举个例子，假设你的参考编号在D列（因为你之前用D列去重），那正确的搜索值应该是Sheet1.Cells(Status.Row, "D").Value，而不是CodeCol.Value。

另外，你的判断逻辑可以简化，原来的：

If Not Code Is Nothing Then
Else
    Status.EntireRow.Copy PasteCell
End If

直接写成If Code Is Nothing Then Status.EntireRow.Copy PasteCell会更清晰。

额外优化：缩小遍历范围，避免空跑 #

你原来遍历G2:G999999，哪怕Sheet1只有几百行数据，也要循环几十万次，这会严重拖慢速度。正确的做法是只遍历有实际数据的行：

Dim lastRowSheet1 As Long
lastRowSheet1 = Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row
Set StatusCol = Sheet1.Range("G2:G" & lastRowSheet1)

修复后的完整代码 #

下面是修正后的代码，同时加入了效率优化（关闭屏幕更新、禁用事件），确保运行流畅：

Sub UpdateExpirySheets()
    Dim StatusCol As Range
    Dim Status As Range
    Dim lastRowSheet1 As Long, lastRowSheet3 As Long, lastRowSheet4 As Long
    Dim targetRefID As String
    Dim foundRefID As Range
    
    ' 开启效率模式，避免卡顿
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 只遍历Sheet1中有数据的行
    lastRowSheet1 = Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row
    Set StatusCol = Sheet1.Range("G2:G" & lastRowSheet1)
    
    For Each Status In StatusCol
        ' 获取当前行的参考编号（假设在D列，根据实际列调整）
        targetRefID = Sheet1.Cells(Status.Row, "D").Value
        
        ' 处理"about to expire"状态，复制到Sheet3
        If Status.Value = "about to expire" Then
            With Sheet3
                lastRowSheet3 = .Cells(.Rows.Count, "D").End(xlUp).Row
                ' 在Sheet3的D列查找是否已有该参考编号
                Set foundRefID = .Range("D2:D" & lastRowSheet3).Find( _
                    What:=targetRefID, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                
                ' 找不到才复制
                If foundRefID Is Nothing Then
                    If .Range("A2").Value = "" Then
                        Status.EntireRow.Copy .Range("A2")
                    Else
                        Status.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                    End If
                End If
            End With
        End If
        
        ' 处理"expired"状态，复制到Sheet4
        If Status.Value = "expired" Then
            With Sheet4
                lastRowSheet4 = .Cells(.Rows.Count, "D").End(xlUp).Row
                Set foundRefID = .Range("D2:D" & lastRowSheet4).Find( _
                    What:=targetRefID, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                
                If foundRefID Is Nothing Then
                    If .Range("A2").Value = "" Then
                        Status.EntireRow.Copy .Range("A2")
                    Else
                        Status.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
                    End If
                End If
            End With
        End If
    Next Status
    
    ' 恢复Excel正常设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

' 绑定文件打开事件，自动运行代码
Private Sub Workbook_Open()
    UpdateExpirySheets
End Sub

更简单的替代方案：清空旧数据再重新复制 #

如果你担心产品状态变化（比如从"about to expire"变成"expired"）导致目标表有遗留数据，其实可以每次运行前先清空Sheet3和Sheet4的旧数据，再重新复制符合条件的行——这个方案逻辑更简单，也不会有重复或遗留问题：

Sub UpdateExpirySheets_ClearFirst()
    Dim StatusCol As Range
    Dim Status As Range
    Dim lastRowSheet1 As Long
    Dim pasteRow3 As Long, pasteRow4 As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 清空Sheet3和Sheet4的内容（保留表头）
    Sheet3.Range("A2:" & Sheet3.Cells(Sheet3.Rows.Count, "XFD").End(xlUp).Address).ClearContents
    Sheet4.Range("A2:" & Sheet4.Cells(Sheet4.Rows.Count, "XFD").End(xlUp).Address).ClearContents
    
    ' 初始化粘贴起始行
    pasteRow3 = 2
    pasteRow4 = 2
    
    lastRowSheet1 = Sheet1.Cells(Sheet1.Rows.Count, "G").End(xlUp).Row
    Set StatusCol = Sheet1.Range("G2:G" & lastRowSheet1)
    
    For Each Status In StatusCol
        If Status.Value = "about to expire" Then
            Status.EntireRow.Copy Sheet3.Cells(pasteRow3, "A")
            pasteRow3 = pasteRow3 + 1
        ElseIf Status.Value = "expired" Then
            Status.EntireRow.Copy Sheet4.Cells(pasteRow4, "A")
            pasteRow4 = pasteRow4 + 1
        End If
    Next Status
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

这个方案运行效率很高，而且不用处理复杂的查找判断，推荐优先考虑。

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