VBA

Question

我正在尝试执行这段代码一段时间，但到目前为止没有成功。如果 sheet Y 中不存在行，我想根据列中数据的比较将行从 sheet X 复制到另一个 sheet Y 的末尾A和C.

当我只需要与一列进行比较时，我已经编写了代码，并且它运行良好。我把它放在那里所以你可以看到:

sourceLastRow = ws_src.Cells(ws_src.Rows.Count, "A").End(xlUp).Offset(1).Row
destLastRow = ws_dest.Cells(ws_dest.Rows.Count, "A").End(xlUp).Offset(1).Row

    For Each rng In ws_src.Range("A2:A" & sourceLastRow)
        Set foundVal = ws_dest.Range("A2:A" & destLastRow).Find(rng, LookIn:=xlValues, lookat:=xlWhole)
        
        If foundVal Is Nothing Then

            rng.EntireRow.Copy
            ws_dest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
              
        End If
    Next rng

不幸的是，当我尝试比较两列时，我没有得到我需要的结果。我尝试了下面的代码，但它不停地复制了我的第一个 sheet 的第一行：

Dim ws_src As Worksheet
Dim ws_dest As Worksheet

Dim rw_src As Range
Dim rw_dest As Range

Set ws_src = Worksheets(1)
Set ws_dest = Worksheets(2)

For Each rw_src In ws_src.Rows

    For Each rw_dest In ws_dest.Rows
        If ws_src.Cells(rw_src.row, 1).Value = ws_dest.Cells(rw_dest.row, 1).Value And ws_src.Cells(rw_src.row, 3).Value = ws_dest.Cells(rw_dest.row, 3).Value Then
        Else: rw_src.EntireRow.Copy
            ws_dest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next rw_dest
Next rw_src

感谢您的宝贵时间！

莉亚

Answer 1

这是您要查找的内容的简单示例。修改代码以满足您的需要并尝试：

Option Explicit

Sub test()
    
    Dim wsSource As Worksheet, wsDestination As Worksheet
    Dim LastRowSource As Long, LastRowDestination As Long
    Dim i As Long, y As Long
    Dim Value_1 As String, Value_2 As String
    Dim ValueExists As Boolean
    
    With ThisWorkbook
        Set wsSource = .Worksheets("Sheet1")
        Set wsDestination = .Worksheets("Sheet2")
    End With
    
    With wsSource
    
        'Find the last row of Column A, wsSource
        LastRowSource = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        'Loop Column A, wsSource
        For i = 1 To LastRowSource
        
            'Let's say we are testing Columns A & B
            Value_1 = .Range("A" & i).Value
            Value_2 = .Range("B" & i).Value
            
            ValueExists = False
            
            With wsDestination
            
                'Find the last row of Column A, wsDestination
                LastRowDestination = .Cells(.Rows.Count, "A").End(xlUp).Row
                
                'Loop Column A, wsDestination
                For y = 1 To LastRowDestination
                
                    If .Range("A" & y).Value = Value_1 And .Range("B" & y).Value = Value_2 Then
                        ValueExists = True
                        Exit For
                    End If
                    
                Next y
                
                'if value does not exist copy
                If ValueExists = False Then
                    .Range("A" & LastRowDestination + 1).Value = Value_1
                    .Range("B" & LastRowDestination + 1).Value = Value_2
                End If
                
            End With
            
        Next i
        
    End With
    
End Sub

Answer 2

试试这个

Option Explicit

Sub Sample()
    Dim ws_src As Worksheet
    Dim ws_dest As Worksheet
    
    '~~> Change as applicable
    Set ws_src = Sheet1
    Set ws_dest = Sheet2
    
    Dim lRow As Long
    Dim i As Long
    
    '~~> Find Last row in ws_src
    With ws_src
        .AutoFilterMode = False
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    
    Dim rngToCopy As Range, FilteredRange As Range
    Dim NewRow As Long
    
    With ws_dest
        '~~> Find Last row in ws_dest
        NewRow = .Range("A" & .Rows.Count).End(xlUp).Row
        For i = 2 To lRow
            .AutoFilterMode = False
            
            '~~> Put the filters
            .Range("A1:C" & NewRow).AutoFilter Field:=1, Criteria1:="=" & ws_src.Cells(i, 1).Value2
            .Range("A1:C" & NewRow).AutoFilter Field:=3, Criteria1:="=" & ws_src.Cells(i, 3).Value2

            Set FilteredRange = .Range("A1:C" & NewRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
            
            '~~> If no match found then store the row in an object
            If Application.CountA(FilteredRange) = 0 Then
                If rngToCopy Is Nothing Then
                    Set rngToCopy = ws_src.Rows(i)
                Else
                    Set rngToCopy = Union(rngToCopy, ws_src.Rows(i))
                End If
            Else
                Set FilteredRange = Nothing
            End If
        Next i
        .AutoFilterMode = False
    End With
    
    '~~> Do the copy in one go
    If Not rngToCopy Is Nothing Then rngToCopy.Copy ws_dest.Rows(NewRow + 1)
End Sub

重要提示：无论您采用什么方法，无论是.Find还是.Autofilter或其他任何方法，都不要在循环中复制粘贴.会很慢。最后复制如上图

VBA - 如果行不存在，则根据 A 列和 C 列将行从 sheet X 复制到 sheet Y

VBA - Copy rows from a sheet X to a sheet Y if rows doesn't already exists, based on column A and column C

excel

copy

compare

rows