VBA値が一致する場合に/の場合に行をコピーします* Brain Fried *

debugcn 投稿 Dev

JCアギレ

列Aに一意の識別子が付いたMasterlist（古いデータ）とResults（新しいデータ）の2枚のワークブックがあります。

ResultsタブからMasterlistシートの一致する行に最新のデータを含む行をコピーする方法を見つけようとしています

下部にある新しいデータをコピーする方法を見つけることしかできませんでした Masterlist

Sub UpdateML()

Dim wM As Worksheet,  wR As Worksheet
Dim r1 As Range, r2 As Range
Dim cel1 As Range, cel2 As Range
Dim LastRow As Long
Application.ScreenUpdating = False

Set wM = ThisWorkbook.Worksheets("MasterList")
Set wR = ThisWorkbook.Worksheets("Results")

    With wM
    Set r1 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With

With wR
    Set r2 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With

On Error Resume Next
For Each cel1 In r1
    With Application
        Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0)) 'find match in Masterlist
        If Err = 0 Then
            copyResult cel2 'copy result to masterlist
        End If
        Err.Clear

End With

Next cel1

End Sub

Sub copyResult(cel As Range)

Dim w As Worksheet, r As Range
Set w = ThisWorkbook.Worksheets("Masterlist")
Set r = w.Cells(w.Rows.Count, Columns("A:A").Column).End(xlUp).Offset(1) 'next row
cel.EntireRow.Copy w.Cells(r.Row, 1)

End Sub

ジョニフェン

copyResultメソッド（rの値を設定する場合）は一番下の行+ 1を取得しているため、リストの一番下にダンプされます。

ただし、UpdateMLメソッドにLastRow変数がありますが、これは使用されていません。これをカウンター変数として使用して行インデックスを追跡し、それをcopyResultメソッドに渡すことで機能するようになりました。このような：

Sub UpdateML()
    Dim wM As Worksheet, wR As Worksheet
    Dim r1 As Range, r2 As Range
    Dim cel1 As Range, cel2 As Range
    Dim LastRow As Long
    Application.ScreenUpdating = False

Set wM = ThisWorkbook.Worksheets("MasterList")
Set wR = ThisWorkbook.Worksheets("Results")

With wM
    Set r1 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With

With wR
    Set r2 = .Range("A1", .Cells(.Rows.Count, .Columns("A:A").Column).End(xlUp))
End With

LastRow = 1

On Error Resume Next
For Each cel1 In r1
    With Application
        Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0)) 'find match in Masterlist
        If Err = 0 Then
            copyResult cel2, LastRow 'copy result to masterlist
        End If
        Err.Clear
        LastRow = LastRow + 1
    End With
Next cel1
End Sub

Sub copyResult(cel As Range, row As Long)
    Dim w As Worksheet
    Set w = ThisWorkbook.Worksheets("Masterlist")
    cel.EntireRow.Copy w.Cells(row, 1)
End Sub

私はVBAに少し錆びているので（約1年は使用されていません）、よりエレガントなソリューションがあるかもしれませんが、これは間違いなく1つのオプションです。

この記事はインターネットから収集されたものであり、転載の際にはソースを示してください。

侵害の場合は、連絡してください[email protected]