Question

我有一个Excel工作簿，其中包含一个用于跟踪项目及其当前位置的主工作表，以及另一个用于跟踪过去位置或项目位置的工作表。目前，当在主工作表中更改记录时，将手动复制该行并将其粘贴到第二个工作表中。我想创建一个宏，它可以在主表单中找到不在第二张表中的项目，并在记录更改时将它们复制到第二页。

下面是我发现并修改的示例宏，它是关闭的，但它会复制并粘贴所有行，而不是新的或不同的行。只需要在A，B和D列上比较行。

Public Sub Sample()
Dim shM As Worksheet, sh2 As Worksheet
Dim shMData As Variant
Dim sh2DataA As Variant
Dim sh2Data As Variant
Dim iM As Long, os2 As Long, i2 As Variant
Dim DoSearch As Boolean

Set shM = Sheets(1)
Set sh2 = Sheets(2)

With shM
    shMData = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4)
End With

DoSearch = False
For iM = 2 To UBound(shMData, 1)
    With sh2
        sh2DataA = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 1)
        sh2Data = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4)
    End With
    os2 = 0
    Do
        If UBound(shMData, 1) > 1 Then
            i2 = Application.Match(shMData(iM, 1), sh2DataA, 0)

        Else
            If shMData(iM, 1) = sh2DataA Then
                i2 = 1
            Else
                i2 = CVErr(xlErrNA)
            End If

        End If

        If Not IsError(i2) Then

                If (shMData(iM, 2) = sh2Data(i2, 2)) And (shMData(iM, 4) = sh2Data(i2, 4)) Then
                MsgBox "Match found Master = " & iM & ", sheet2 = " & i2 + os2

                Else

                    shM.Activate
                    shM.Range(Cells(iM, 1), Cells(iM, 7)).Select
                    Selection.Copy

                    sh2.Select
                    FinalRow = Range("A65536").End(xlUp).Row
                    NextRow = Range("A65536").End(xlUp).Row + 1
                    Range("A" & NextRow).Select
                    ActiveSheet.Paste

                End If


            os2 = os2 + i2
            If os2 < UBound(sh2Data, 1) Then
                With sh2
                    sh2DataA = .Range(.Cells(i2 + os2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 1)
                    sh2Data = .Range(.Cells(i2 + os2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4)
                End With
                DoSearch = True

            Else
                DoSearch = False
            End If

        Else
            shM.Activate
            shM.Range(Cells(iM, 1), Cells(iM, 7)).Select
            Selection.Copy

            sh2.Select
            FinalRow = Range("A65536").End(xlUp).Row
            NextRow = Range("A65536").End(xlUp).Row + 1
            Range("A" & NextRow).Select
            ActiveSheet.Paste

            DoSearch = False
        End If
    Loop Until Not DoSearch
Next
End Sub

仅添加消息框以验证代码是否正常工作 - 它不是必需的组件。再次感谢您提供任何建议。

Answer 1

假设您在主列表中从未获得完全相同的两行，您可以使用内置的Excel功能删除重复项（至少在2010年的数据选项卡上）。如果您有x个重复的行，则完全相同，其中x-1将被删除。因此，您可以复制整个其他表，将其粘贴到主列表下，然后在主列表上运行删除重复项。您需要知道的是用于删除重复项的VBA。

    ActiveSheet.Range("$A$40:$D$43").RemoveDuplicates Columns:=Array(1, 3, 4), Header:=xlNo

根据需要进行调整

Answer 2

谢谢大家的帮助我找到了一个解决方案，但它在Excel 2003中不起作用。如果有人知道他们的头脑，为什么那将是伟大的其他我想我弄清楚了。这是代码。

[HTML] Public Sub NewEntWhole（） Dim loM作为ListObject，lo2作为ListObject Dim TblMData As Variant Dim iM As Long Dim dDate As Date Dim strDate As String Dim lDate As Long Dim rng As Range Dim ct As Variant Dim shM As Worksheet Dim sh2 As Worksheet Dim hdM As Integer

hdM = 0 'rows above table M
Set shM = Sheets(1)
Set sh2 = Sheets(2)
Set loM = Sheets(1).ListObjects(1)
Set lo2 = Sheets(2).ListObjects(1)



With loM
    TblMData = .DataBodyRange
End With

For iM = 2 To UBound(TblMData, 1) + 1
    sh2.Activate


    With lo2
        .Range.AutoFilter Field:=1, Criteria1:=loM.Range(iM, 1).Value
        .Range.AutoFilter Field:=2, Criteria1:=loM.Range(iM, 2).Value

        If IsDate(loM.Range(iM, 4)) Then
            sDate = loM.Range(iM, 4)
            dDate = DateSerial(Year(sDate), Month(sDate), Day(sDate))
            lDate = dDate
            .Range.AutoFilter Field:=4, Criteria1:=">=" & lDate, Operator:=xlAnd, Criteria2:="<" & lDate + 1
        Else
            .Range.AutoFilter Field:=4, Criteria1:=loM.Range(iM, 4).Value
        End If


    End With

   Set rng = lo2.AutoFilter.Range

    ct = rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

    If ct = 0 And loM.Range(iM, 1).Value > 0 Then

        shM.Activate
        shM.Range(Cells((iM + hdM), 1), Cells((iM + hdM), 7)).Copy

        sh2.Activate
        FinalRow = Range("B65536").End(xlUp).Row
        NextRow = Range("B65536").End(xlUp).Row + 1
        Range("A" & NextRow).Select
        ActiveSheet.Paste

    End If

    With lo2
        .Range.AutoFilter Field:=1
        .Range.AutoFilter Field:=2
        .Range.AutoFilter Field:=4
    End With
Next
shM.Activate

结束子[/ HTML]

将行从一个表复制到另一个表而不创建重复项

2 个答案: