2

アイテムとその現在の場所を追跡するマスター シートと、過去の場所またはアイテムの場所を追跡する別のシートを含む Excel ブックがあります。現在、マスター シートでレコードが変更されると、その行は手動でコピーされ、2 番目のシートに貼り付けられます。2 番目のシートにないマスター シートのアイテムを検索し、レコードが変更されたときに 2 番目のシートにコピーするマクロを作成したいと考えています。

以下は、私が見つけて修正したマクロのサンプルですが、新しい行や別の行ではなく、すべての行をコピーして貼り付けます。行は、列 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

マスター リストにまったく同じものが 2 行も表示されないと仮定すると、組み込みの 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 に答える