0

これが私が達成しようとしていることの背景です。

10 枚のシートを含む Excel ファイルがあり、各シートには多数のデータ行が含まれています。このワークブックはさまざまな人に送信され、それぞれがそれぞれの情報を列 A、B にのみ入力します。塗りつぶされたすべてのワークブックをループし、セルAxがBx塗りつぶされている行をチェックするvbaスクリプトを作成しました。次に、それらを新しいワークブックにコピーします。

だから私が今持っているのは：

  1. 列 A、B が入力された行のみを含むワークブック。
  2. 未入力の行をすべて含むワークブック。(最初のもの)

私が今やりたいことは、行ごとにチェックし、ワークブックAのシート 1 の行 1 から、ワークブックのBシート 1の列 A、B を引いたものを見つけることです。行が見つかったら、ワークブックのB行をその行に置き換える必要があります。ワークブックAから。

したがって、最終的には、塗りつぶされた行と塗りつぶされていない行の両方を含む1 つのマスター ワークブック (以前はワークブックB ) が残ります。

これをあまり複雑にしていないことを願っています。これを達成するための最良の方法についての洞察をいただければ幸いです。

4

1 に答える 1

1

コメントで述べたように、.Find達成しようとしていることに使用することができます。以下のコード サンプルでは、​​ワークブックAとB. 次に、 Workbook の Col C の値をループし、 Workbook の Col CAでその値の出現を見つけようとしますB。一致が見つかった場合は、その行のすべての列を比較します。Bそして、すべての列が一致する場合は、 workbook の値に基づいて、workbook の Col A と Col B に書き込みますA。一致が見つかると.FindNext、列 C でのさらなる一致に使用されます。

C:\A.xlsこれをテストするには、提供されたファイルをおよびそれぞれ名前を付けて保存しますC:\B.xls。新しいワークブックを開き、モジュールにこのコードを貼り付けます。コードはSheet7ワークブックAとSheet7ワークブックを比較していますB

残りのシートについては修正できると思います

試行錯誤済み(投稿の最後にあるスナップショットを参照)

Sub Sample()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim ws1LRow As Long, ws2LRow As Long
    Dim i As Long, j As Long
    Dim ws1LCol As Long, ws2LCol As Long
    Dim aCell As Range, bCell As Range
    Dim SearchString As String
    Dim ExitLoop As Boolean, matchFound As Boolean

    '~~> Open File 1
    Set wb1 = Workbooks.Open("C:\A.xls")
    Set ws1 = wb1.Sheets("sheet7")
    '~~> Get the last Row and Last Column
    With ws1
        ws1LRow = .Range("C" & .Rows.Count).End(xlUp).Row
        ws1LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With

    '~~> Open File 2
    Set wb2 = Workbooks.Open("C:\B.xls")
    Set ws2 = wb2.Sheets("sheet7")
    '~~> Get the last Row and Last Column
    With ws2
        ws2LRow = .Range("C" & .Rows.Count).End(xlUp).Row
        ws2LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With

    '~~> Loop Through Cells of Col C in workbook A and try and find it
    '~~> in Col C of workbook 2
    For i = 2 To ws1LRow
        SearchString = ws1.Range("C" & i).Value

        Set aCell = ws2.Columns(3).Find(What:=SearchString, LookIn:=xlValues, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

        ExitLoop = False

        '~~> If match found
        If Not aCell Is Nothing Then
            Set bCell = aCell

            matchFound = True

            '~~> Then compare all columns
            For j = 4 To ws1LCol
                If ws1.Cells(i, j).Value <> ws2.Cells(aCell.Row, j).Value Then
                    matchFound = False
                    Exit For
                End If
            Next

            '~~> If all columns matched then wrtie to Col A/B
            If matchFound = True Then
                ws2.Cells(aCell.Row, 1).Value = ws1.Cells(i, 1).Value
                ws2.Cells(aCell.Row, 2).Value = ws1.Cells(i, 2).Value
            End If

            '~~> Find Next Match
            Do While ExitLoop = False
                Set aCell = ws2.Columns(3).FindNext(After:=aCell)

                '~~> If match found
                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do

                    matchFound = True

                    '~~> Then compare all columns
                    For j = 4 To ws1LCol
                        If ws1.Cells(i, j).Value <> ws2.Cells(aCell.Row, j).Value Then
                            matchFound = False
                            Exit For
                        End If
                    Next

                    '~~> If all columns matched then wrtie to Col A/B
                    If matchFound = True Then
                        ws2.Cells(aCell.Row, 1).Value = ws1.Cells(i, 1).Value
                        ws2.Cells(aCell.Row, 2).Value = ws1.Cells(i, 2).Value
                    End If
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    Next
End Sub

スナップショット

前

ここに画像の説明を入力

後

ここに画像の説明を入力

于 2012-08-03T09:20:36.307 に答える