2

我有一个 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

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

4

2 回答 2

0

谢谢大家的帮助，我找到了一个解决方案，但它在 Excel 2003 中不起作用。如果有人知道他们的头脑为什么会很好，否则我想我想明白了。这是代码。

[HTML]Public Sub NewEntWhole() Dim loM As ListObject, lo2 As 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作为工作表将 hdM 调暗为整数

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]

于 2012-11-06T00:12:52.450 回答
0

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

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

根据需要进行调整

于 2012-11-03T20:27:21.873 回答