キーワードをもとに表を転記する

VBAで表の内容を転記する

共通するワードをキーとしてシートから別シートに転記するVBAを作成しました．

目次

1. 事前準備
2. 部分説明
3. 完成

1.事前準備

下記のようにExcel上で２つのシートを用意します。
シート1にシート2の内容を転記するようにVBAを書いていきます。

・シート1　（転記を受け取るシート）

・シート2（送る側のシート）

2.部分説明

ここでは特筆する必要のある個所を説明していきます。

・シートの名前セット
宣言することでこれ以降シート１をSh1として扱います。

Set Sh1 = ThisWorkbook.Worksheets("Sheet1")

・最終行取得
下記のコードでシート内の最終行を取得します。
これをもとにループの終了判定を取ります。

Worksheets("xxxx").Range("xx").End(xlDown).Row 

・転記
シート１の１行目から２行目にシート２の３行目から４行目を転記します。
数値を変えることで範囲を変えることも可能です。

Range(Sh1.Cells(line_count, 1), Sh1.Cells(line_count, 2)).Value =                
          Range(Sh2.Cells(keyword_count, 3), Sh2.Cells(keyword_count, 4)).Value 

3.完成

最終的にはこのようなコードになりました。
変数宣言無駄に多くなってしまったのでもう少しスマートに書けるようになりたいですね。
どなたかの参考になれば幸いです。

Sub ボタン1_Click() 
   '変数の定義 
   Dim i As Integer 
   Dim Sh1 As Worksheet 
   Dim Sh2 As Worksheet 
   Dim count_loop As Long 'While文のカウント 
   Dim keyword_count As Long 'シート2のキーワード行カウント 
   Dim keyword_column As Long 'シート1のキーワード列参照 
   Dim keyword_lastcell As Long 'シート2の最終行参照 
   Dim start As Long 'シート1の開始行 
   Dim end_count As Long 'シート1の最終行 
   Dim line_count As Long 'シート1の参照行 
   count_loop = 1 
   keyword_column = 3 ' シート１の参照列指定 
   keyword_lastcell = Worksheets("Sheet2").Range("B5").End(xlDown).Row + 1 ' シート2の最終行取得 
   Application.ScreenUpdating = False ' 描画を停止する 'ワークシートを指定する 
   Set Sh1 = ThisWorkbook.Worksheets("Sheet1") 
   Set Sh2 = ThisWorkbook.Worksheets("Sheet2") 
   start = (Sh1.Cells(1, 1).End(xlDown).Row) 
   end_count = (Sh1.Cells(1, 3).End(xlDown).Row) + 1 ' シート1の入力側最終行取得 
   line_count = start + 1 
   Do While line_count < end_count 'シート2の開始の行 
     keyword_count = 5 
     Do While keyword_count < keyword_lastcell 'キーワード一致 
       If Sh1.Cells(line_count, keyword_column) Like "*" + Sh2.Cells(keyword_count, 2) + "*" Then 
          Range(Sh1.Cells(line_count, 1), Sh1.Cells(line_count, 2)).Value =                
          Range(Sh2.Cells(keyword_count, 3), Sh2.Cells(keyword_count, 4)).Value 
       End If keyword_count = keyword_count + 1 
     Loop 
     line_count = line_count + 1 
   Loop 
End Sub