異なる列の部分セル値を一致させてコピーする

Question

同じブックの2つの異なるシートから2つの列を部分的に比較しようとしています。例えば

：シート2のColumn BはRs ID（すべての数字）を含み、Column AはClinical Significanceを含み、シート1に2列A & B（文字列と数字を含む）の同様に同じヘッダとがあります。

部分一致がSheet2のは、シート1のColumn BでのColumn Bであった場合、私は次の使用例は、シート1でColumn A中で同じセルにSheet2のからColumn Aにセルをコピーするには、私のVBAコードをお勧めします 。

Sheet1の：

のSheet2：

これは私のコードです。それは完璧に実行されますが、Column Bののシート2のデータは、Column Aとまったく同じではありません。 lookat:=xlPartを正しく使用できませんでしたか？

Sub test() 
    Dim rng2 As Range, c2 As Range, cfind As Range 
    Dim x, y 
    With Worksheets("sheet1") 
     Set rng2 = .Range(.Range("B2"), .Range("B2").End(xlDown)) 
     For Each c2 In rng2 
      x = c2.Value 
      With Worksheets("sheet2").Columns("B:B") 
       On Error Resume Next 
       Set cfind = .Cells.Find(what:=x, lookat:=xlPart, LookIn:=xlValues) 
       If (Not (cfind Is Nothing)) Then 
        y = cfind.Offset(0, -1).Value 
        c2.Offset(0, -1) = y 
       End If 
      End With 
     Next c2 
    End With 
End Sub 

Answer 1

あなたは、最初のシートの値を2番目のシート内で探していますが、それは逆になるはずです（;-)）。

これは、あなたが提供したデータで私にとって役立ちます。私は少し異なるアプローチを使用しますが、一般的な考え方は変わりません。

Option Explicit 


Sub test() 

    'declaration 
    Dim ws1 As Worksheet, ws2 As Worksheet 
    Dim c1 As Range, c2 As Range, rng1 As Range, rng2 As Range, cfind As Range 

    'set worksheets 
    Set ws1 = ActiveWorkbook.Sheets(1) 
    Set ws2 = ActiveWorkbook.Sheets(2) 

    'define ranges to look in/for 
    With ws1 
    Set rng1 = .Range(.Cells(2, 2), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2)) 
    End With 
    With ws2 
    Set rng2 = .Range(.Cells(2, 2), .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2)) 
    End With 

    'loop through the values in sheet 1 
    For Each c1 In rng1 
    'loop through the values in sheets 2 
    For Each c2 In rng2 
     On Error Resume Next 
     'look for the value from sheet 2, in sheet 1 
     Set cfind = c1.Find(what:=c2.Value, lookat:=xlPart, LookIn:=xlValues) 
     'is a partial match found? then copy the value from column sheet2-colA from c2 to sheet1-colA for c1 
     If (Not (cfind Is Nothing)) Then 
      c1.Offset(0, -1).Value = c2.Offset(0, -1).Value 
     End If 
     'emtpy the found range 
     Set cfind = Nothing 
    Next c2 
    Next c1 

'SUCCESS!! 

End Sub 

常にrng2のすべての値をループします。したがって、c1の値がrng2の複数のセルにある場合、前回の一致を最新のfindで上書きします！