Excel/VBA

TOP

別シート又は別ブックから条件が一致したら転記する方法

条件が一致したら転記する方法の説明画像です

※当サイトで使用するデータは全て架空のサンプルデータです。

目次

別シートから商品の価格を転記する例

タイトル画像のように、商品名が一致する価格を転記する方法を解説していきます。

別シートから条件が一致した値を転記するには、下記のように転記元のシートと転記先シートの指定を行います。


  Dim WsTenkiMoto As Worksheet
  Dim WsTenkiSaki As Worksheet

  Set WsTenkiMoto = ThisWorkbook.Worksheets("転記元データ")  '転記元のシート
  Set WsTenkiSaki = ThisWorkbook.Worksheets("転記先")       '転記先のシート
        

条件と一致する値を転記していくには、転記先の最初の行から最後の行まで繰り返し処理を行い、商品名を転記元シートからFindを使用して検索しながら転記をしていきます。

下記の例は、指定した列から値を検索する例です。

Columns(検索する列).Find(検索する値)

行を指定して検索する場合は下記のようになります。

Rows(検索する列).Find(検索する値)

セルの範囲を指定して検索をする場合は下記のようになります。

Range(検索するセル範囲).Find(検索する値)

下記のようにLookAt:=xlWholeと指定すると完全一致で検索するように設定できます。
LookAt:=xlPartと指定すると部分一致で検索することになります。

Range(検索するセル範囲).Find(検索する値, LookAt:=xlWhole) ・・・ 完全一致で検索 Range(検索するセル範囲).Find(検索する値, LookAt:=xlPart)  ・・・ 部分一致で検索


下記のサンプルコードは、転記先の2行目から最終行までループを行いFindにて転記元の商品名から検索をし、同じ商品名が見つかった場合は価格を転記しています。
もし見つからなかった場合は、価格のセルを黄色で塗りつぶしています。

サンプルコード


Sub 価格転記_別シート()
    
    '変数を用意します
    Dim WsTenkiMoto As Worksheet
    Dim WsTenkiSaki As Worksheet
    Dim SearchValue As String
    Dim FindRng As Range
    Dim i As Long, LastRow As Long
    
    '転記元と転記先のシートを指定します
    Set WsTenkiMoto = ThisWorkbook.Worksheets("転記元データ")
    Set WsTenkiSaki = ThisWorkbook.Worksheets("転記先")
    
    '転記先の最終行を取得します
    LastRow = WsTenkiSaki.Cells(Rows.Count, "A").End(xlUp).Row
    
    '転記先シートの2行目から最終行までをループします
    For i = 2 To LastRow
        
        '検索する文字を指定します
        SearchValue = WsTenkiSaki.Cells(i, "B").Value
        
        '転記元データのシートのB列から同じ商品名を検索します(LookAt:=xlWhole = 完全一致)
        Set FindRng = WsTenkiMoto.Columns("B").Find(SearchValue, LookAt:=xlWhole)
        
        '転記元データのB列から条件に一致する値が見つかった場合、価格を転記します(見つからなかった場合は、価格のセルを黄色で塗りつぶします)
        If Not FindRng Is Nothing Then
            WsTenkiSaki.Cells(i, "D").Value = WsTenkiMoto.Cells(FindRng.Row, "D").Value  '見つかった場合
        Else
            WsTenkiSaki.Cells(i, "D").Interior.Color = vbYellow  '見つからなかった場合
        End If
        
    Next i
    
    'リソースを開放します
    Set FindRng = Nothing
    Set WsTenkiMoto = Nothing
    Set WsTenkiSaki = Nothing
    
End Sub
        

上記のサンプルコードでは「If Not FindRng Is Nothing Then」の箇所で同じ商品名が見つかったかを判断しています。

もし、検索した値が見つからなかった場合、FindRngには「Nothing」が返されます。

FindRngにNothingが返されたかを「Is Nothing」の箇所で判断をしています。

別ブックから商品の価格を転記する例

条件が一致したら転記する方法の説明画像です

別ブックから条件が一致した値を転記するには、下記のように転記元のブックをOpenメソッドで開き、開いたブックのデータを取得するシートを指定します。


  Dim WbTenkiMoto As Workbook
  Dim WsTenkiMoto As Worksheet

  '下記のフルパスは転記元のデータがある場所を指定してください
  Set WbTenkiMoto = Workbooks.Open("C:\Users\○○\Desktop\転記元.xlsm")
  Set WsTenkiMoto = WbTenkiMoto.Worksheets("転記元データ")
        

以降は別シートからデータを転記する時と同様に転記元データから一致するデータを検索しながら転記をしていきます。

下記が別ブックから転記するサンプルコードです。

サンプルコード


Sub 価格転記_別ブック()

    '変数を用意します
    Dim WbTenkiMoto As Workbook
    Dim WsTenkiMoto As Worksheet
    Dim WsTenkiSaki As Worksheet
    Dim SearchValue As String
    Dim FindRng As Range
    Dim i As Long, LastRow As Long
    
    '転記元のブックを開きます(下記のフルパスは転記元のデータがある場所を指定してください)
    Set WbTenkiMoto = Workbooks.Open("C:\Users\○○\Desktop\転記元.xlsm")
    
    '転記元と転記先のシートを指定します
    Set WsTenkiMoto = WbTenkiMoto.Worksheets("転記元データ")
    Set WsTenkiSaki = ThisWorkbook.Worksheets("転記先")
    
    '転記先の最終行を取得します
    LastRow = WsTenkiSaki.Cells(Rows.Count, "A").End(xlUp).Row
    
    '転記先シートの2行目から最終行までをループします
    For i = 2 To LastRow
        
        '検索する文字を指定します
        SearchValue = WsTenkiSaki.Cells(i, "B").Value
        
        '転記元データのシートのB列から同じ商品名を検索します(LookAt:=xlWhole = 完全一致)
        Set FindRng = WsTenkiMoto.Columns("B").Find(SearchValue, LookAt:=xlPart)
        
        '転記元データのB列から条件に一致する値が見つかった場合、価格を転記します(見つからなかった場合は、価格のセルを黄色で塗りつぶします)
        If Not FindRng Is Nothing Then
            WsTenkiSaki.Cells(i, "D").Value = WsTenkiMoto.Cells(FindRng.Row, "D").Value  '見つかった場合
        Else
            WsTenkiSaki.Cells(i, "D").Interior.Color = vbYellow  '見つからなかった場合
        End If
        
    Next i
    
    'リソースを開放します
    Set FindRng = Nothing
    Set WsTenkiMoto = Nothing
    Set WsTenkiSaki = Nothing
    Set WbTenkiMoto = Nothing
    
End Sub
        

関連記事