Excel VBA - 2つの列の値を比較し、一致する行を新しいシートにコピーします。

Question

シートAの列AとシートAの列Aを比較しようとしています。一致する場合は、シート1から列3をコピーします。ここに私が持っているコードがありますが、それは動作していません。

あなたの言葉遣い次

Sub compareAndCopy() 

Dim lastRowE As Integer 
Dim lastRowM As Integer 
Dim foundTrue As Boolean 

' stop screen from updating to speed things up 
Application.ScreenUpdating = False 

lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row 
lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row 
lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row 



For i = 1 To lastRowE 
foundTrue = False 
For j = 1 To lastRowF 

    If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then 
     'MsgBox ("didnt find string: " & Sheets("Sheet2").Cells(i, 2).value) 
     Sheets("Sheet2").Rows(i).Copy Destination:= _ 
     Sheets("Sheet3").Rows(lastRowM + 1) 

     Exit For 
    End If 

Next j 

If Not foundTrue Then 
    lastRowM = lastRowM + 1 
    foundTrue = True 

End If 


Next i 

' stop screen from updating to speed things up 
Application.ScreenUpdating = True 

End Sub 

Answer 1

：私はシート1からシート3に行をコピーし、マッチがあります のSheet1にcolumnAへのSheet2の列Aを比較しようとしています

。

あなたはこの

Sub RowFinder() 
    Dim sheet1Data As Variant 

    With Worksheets("Sht2") '<--| reference your worksheet 2 
     sheet1Data = Application.Transpose(.Range("A1", .Cells(.Rows.count, 1).End(xlUp)).Value) 
    End With 
    With Worksheets("Sht1") '<--| reference your worksheet 1 
     With .Range("A1", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one 
      .AutoFilter field:=1, Criteria1:=sheet1Data, Operator:=xlFilterValues '<--| filter cells with sheet 2 column A values 
      If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=Worksheets("Sht3").Range("A1") 
     End With 
     .AutoFilterMode = False 
    End With 
End Sub 

Answer 2

としては、foundTrueに基づいてlastRowMのあなたの更新が機能していないスコットCranerが指摘してみてください。 foundTrueは、Sheet3に新しい行を追加するたびにlastRowMを更新する限り、実際には必要ありません。 する場合値が見つからない場合にメッセージを表示したい場合は、コード内に保管しておきます。

Sub compareAndCopy() 

    Dim lastRowE As Long 
    Dim lastRowF As Long 
    Dim lastRowM As Long 
    Dim foundTrue As Boolean 

    ' stop screen from updating to speed things up 
    Application.ScreenUpdating = False 

    lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row 
    lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row 
    lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row 

    For i = 1 To lastRowE 
     foundTrue = False 
     For j = 1 To lastRowF 

      If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then 
       lastRowM = lastRowM + 1 
       Sheets("Sheet2").Rows(i).Copy Destination:= _ 
          Sheets("Sheet3").Rows(lastRowM) 
       foundTrue = True 
       Exit For 
      End If 
     Next j 
     'If Not foundTrue Then 
     ' MsgBox ("didn't find string: " & Sheets("Sheet2").Cells(i, 2).value) 
     'End If 
    Next i 

    ' stop screen from updating to speed things up 
    Application.ScreenUpdating = True 
End Sub