一問一答の一歩

表が複数ある場合、一つの表の項目に対応する値を他の表から引っ張ってくるなんていうことがときどき起こったりする。

これは量が多くなると、かなりの手間となり、効率化による影響が大きい部分である。

なお、効率化の方法には2 つの方法が考えられる。

• ・関数を作成する
• ・マクロを作成する

今回はマクロを作成する方法を紹介する予定であり、マクロを用いることによるメリットは以下の通りである。

• ・2つの表の並び方が、違っていても、対応しやすい
• ・ファイルの位置が変わったとしても影響が小さい

実行のための設定を行うためのエクセルシ－トは以下のようなものを前提としており、ボタンを押すことで実行できるようにしています。

また、書換の対象となる表は以下のようなものを想定しており、項目が横に並んでいるものを想定しています。

VBAのソ－スコードについては以下の通りです。

Sub Copy_value

'----------------------------------------------
'概要:2つのエクセルシートの該当行を比較し、一致している項目の値を書き写す
'機能名:Copy_value
'引数:なし
'戻り値:なし
'備考:
'----------------------------------------------

	Dim readsheet As Worksheet
	Dim writesheet As Worksheet
	Dim optional_sheet As Worksheet
	Dim readbook_name As String
	Dim writebook_name As String
	Dim readbook_kakutyoshi As String
	Dim writebook_kakutyoshi As String
	Dim readsheet_name As String
	Dim writesheet_name As String
	Dim readsheet_index_column As Integer
	Dim writesheet_index_column As Integer
	Dim readsheet_contents_column As Integer
	Dim writesheet_contents_column As Integer
	Dim readsheet_start_row As Integer
	Dim writesheet_start_row As Integer
	Dim readsheet_last_row As Integer
	Dim writesheet_last_row As Integer
	Dim readsheet_row_number As Integer
	Dim writesheet_row_number As Integer
	Dim readsheet_transposition_flag As Integer
	Dim writesheet_transposition_flag As Integer
	
	Set optional_sheet =  Worksheets("シート名")
	'4Dのセルに入力した参照元ブック名を参照する
	readbook_name = optional_sheet.Cells(4,4).Value
	'4Eのセルに入力した参照元ブック名を参照する
	writebook_name = optional_sheet.Cells(4,5).Value
	If optional_sheet.Cells(5,4).Value = "" Then
	'拡張子を自動でxlsxに設定
	readbook_kakutyoshi = ".xlsx"
	Else 
	'5Dのセルに入力した拡張子を参照する
	readbook_kakutyoshi = optional_sheet.Cells(5,4).Value
	End If
	If optional_sheet.Cells(5,4).Value = "" Then
	'拡張子を自動でxlsxに設定
	writebook_kakutyoshi = ".xlsx"
	Else 
	'5Eのセルに入力した拡張子を参照する
	writebook_kakutyoshi = optional_sheet.Cells(5,5).Value
	End If
	'6Dのセルに入力した記載先シート名を参照する
	readsheet_name = optional_sheet.Cells(6,4).Value
	'6Eのセルに入力した記載先シート名を参照する
	writesheet_name = optional_sheet.Cells(6,5).Value
	'7Dのセルに入力したインデックス列番号を参照する
	readsheet_index_column = optional_sheet.Cells(7,4).Value
	'7Eのセルに入力したインデックス列番号を参照する
	writesheet_index_column = optional_sheet.Cells(7,5).Value
	'8Dのセルに入力した転記列番号を参照する
	readsheet_contents_column = optional_sheet.Cells(8,4).Value
	'8Eのセルに入力した転記列番号を参照する
	writesheet_contents_column = optional_sheet.Cells(8,5).Value
	'9Dのセルに入力した転記開始行番号を参照する
	readsheet_start_row = optional_sheet.Cells(9,4).Value
	'9Eのセルに入力した転記開始行番号を参照する
	writesheet_start_row = optional_sheet.Cells(9,5).Value
	'10Dのセルに入力した行列転置の有無を参照する
	readsheet_transposition_flag = optional_sheet.Cells(10,4).Value
	'10Eのセルに入力した行列転置の有無を参照する
	writesheet_transposition_flag = optional_sheet.Cells(10,5).Value
	
	If readbook_name="" Then
		If readsheet_name ="" Then
			Set readsheet=Worksheets(1)
		Else
			Set readsheet=Worksheets(readsheet_name)
		End If
	Else
		If readsheet_name ="" Then
			Set readsheet=Workbooks(readbook_name & readbook_kakutyoshi).Worksheets(1)
		Else
			Set readsheet=Workbooks(readbook_name & readbook_kakutyoshi).Worksheets(readsheet_name)
		End If
	End If
	If writebook_name="" Then
		If writeshee_name ="" Then
			Set writesheet=Worksheets(1)
		Else
			Set writesheet=Worksheets(writesheet_name)
		End If
	Else 
		If writesheet_name ="" Then
			Set writesheet =Workbooks(writebook_name & writebook_kakutyoshi).Worksheets(1)
		Else
			Set writesheet=Workbooks(writebook_name & writebook_kakutyoshi).Worksheets(writesheet_name)
		End If
	End If
	
	'読み込みシートの最終行を取得
	If readsheet_transposition_flag = 1 Then
		readsheet_last_row = readsheet.Cells(readsheet_index_column,Columns.Count).End(xlToLeft).Column
	Else 
		readsheet_last_row = readsheet.Cells(Rows.Count,readsheet_index_column).End(xlup).Row
	End If
	
	'書込みシートの最終列を取得
	If writesheet_transposition_flag = 1 Then
		writesheet_last_row = writesheet.Cells(writesheet_index_column,Columns.Count).End(xlToLeft).Column
	Else 
		writesheet_last_row = writesheet.Cells(Rows.Count,writesheet_index_column).End(xlup).Row
	End If
	
	For readsheet_row_number = readsheet_start_row TO readsheet_last_row
		For writesheet_row_number = writesheet_start_row TO writesheet_last_row

			If readsheet_transposition_flag <> 1 And writesheet_transposition_flag <> 1 Then
			'行列の転置が無い場合
				If writesheet.Cells(writesheet_row_number , writesheet_index_column).Value = readsheet.Cells(readsheet_row_number , readsheet_index_column).Value THEN
					writesheet.Cells(writesheet_row_number , writesheet_contents_column ).Value =readsheet.Cells(readsheet_row_number , readsheet_contents_column).Value
					'該当インデックスの検索を終了する。
					Exit For
				END IF
			ElseIf readsheet_transposition_flag = 1 And writesheet_transposition_flag <> 1 Then
			'読込みシートのみ転置を行う場合
				If writesheet.Cells(writesheet_row_number , writesheet_index_column).Value = readsheet.Cells(readsheet_index_column,readsheet_row_number ).Value THEN
					writesheet.Cells(writesheet_row_number , writesheet_contents_column ).Value =readsheet.Cells(readsheet_contents_column ,readsheet_row_number ).Value
					'該当インデックスの検索を終了する。
					Exit For
				END IF
			ElseIf readsheet_transposition_flag <> 1 And writesheet_transposition_flag = 1 Then
			'書込みシートのみ転置を行う場合
				If writesheet.Cells(writesheet_index_column ,writesheet_row_number ).Value = readsheet.Cells(readsheet_row_number , readsheet_index_column).Value THEN
					writesheet.Cells(writesheet_contents_column , writesheet_row_number ).Value =readsheet.Cells(readsheet_row_number , readsheet_contents_column).Value
					'該当インデックスの検索を終了する。
					Exit For
				END IF
			ElseIf readsheet_transposition_flag = 1 And writesheet_transposition_flag = 1 Then
			'読み込み、書込みの両方とも転置を行う場合
				If writesheet.Cells(writesheet_index_column , writesheet_row_number).Value = readsheet.Cells(readsheet_index_column , readsheet_row_number).Value THEN
					writesheet.Cells(writesheet_contents_column , writesheet_row_number ).Value =readsheet.Cells(readsheet_contents_column , readsheet_row_number).Value
					'該当インデックスの検索を終了する。
					Exit For
				END IF
			End If
			'読み込みシートのみ転置がある場合
		Next writesheet_row_number
	Next readsheet_row_number
End Sub