【VBA】表の変換を行うマクロ
デ一タを取り扱っていると、2つの主キ一と一つのデ一タが対応しているものだけでなく、3つの主キ一から一つのデ一タが対応しているものを取り扱うときかある。
そのようなデ一タを管理する場合、テ一ブルを作成して管理することが多いが、対応表を複数作成して管理を行う状況で、表の転記をするマクロを作成したので情報共有する
なお、以下のことを前提とする、
値決定の条件となる記載対象のデ一タは1対1で存在すること。(ユニ一ク制約)
値決定の条件となる全てのデ一タが決まるともう一つの数字も1つに決定されること(完全関数従属性)
ソースコード
ソースコードは下記の通りです。
Sub conversion_table
'----------------------------------------------
'概要:別の形式のテーブルに変換する。
'機能名:conversion_table
'引数:なし
'戻り値:なし
'備考:
'----------------------------------------------
Dim readsheet 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_row As Integer
Dim writesheet_index_row As Integer
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_row_number As Integer
Dim writesheet_row_number As Integer
Dim readsheet_last_row As Integer
Dim readsheet_last_column As Integer
Dim writesheet_last_row As Integer
Dim writesheet_last_column As Integer
Dim readtablename_row As Integer
Dim readtablename_column As Integer
Dim writetablename_row As Integer
Dim writetablename_column As Integer
Dim loop_readsheets_row As Integer
Dim loop_writesheets_row As Integer
Dim loop_readsheets_column As Integer
Dim loop_writesheets_column As Integer
Dim writesheet As Worksheet
Set optional_sheet = Worksheets("option")
'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
'転記元となる表のインデックス行の位置を取得(表名の何行下か)
readsheet_index_row = optional_sheet.Cells(7,4).Value
'転記元となる表のインデックス列の位置を取得(表名の何列右か)
readsheet_index_column = optional_sheet.Cells(8,4).Value
'転記先となる表のインデックス行の位置を取得(表名の何こ下か)
writesheet_index_row = optional_sheet.Cells(7,5).Value
'転記先となる表のインデックス列の位置を取得(表名の何こ右か)
writesheet_index_column = optional_sheet.Cells(8,5).Value
'読込対象となる表名を取得する※記載が無かったらシート内の全ての表を転記
readsheet_tablename = optional_sheet.Cells(9,4).Value
if readbook_name = "" Then
Set readsheet= ThisWorkbook.Worksheets(readsheet_name)
Else
Set readsheet= Workbooks(readbook_name & readbook_kakutyoshi).Worksheets(readsheet_name)
End If
If writebook_name = "" Then
Set writesheet= ThisWorkbook.Worksheets(writesheet_name)
Else
Set writesheet=Workbooks(writebook_name & writebook_kakutyoshi).Worksheets(writesheet_name)
End If
'転記元のシートの大きさを取得
readsheet_last_row = optional_sheet.Cells(10,4).Value
If readsheet_last_row = 0 Then
'空欄だった場合、一番左の列から行数を推測
readsheet_last_row = readsheet.Cells(Rows.Count, 1).End(xlUp).Row
If readsheet_last_row = 0 Then
'推測もできなかった場合、100を設定
readsheet_last_row = 100
End If
End If
readsheet_last_column = optional_sheet.Cells(11,4).Value
If readsheet_last_column = 0 Then
'空欄だった場合、一番上の行から列数を推測
readsheet_last_column = readsheet.Cells(1, Columns.Count).End(xlToLeft).Column
If readsheet_last_column = 0 Then
'推測もできなかった場合、100を設定
readsheet_last_column = 100
End If
End If
'転記先のシートの大きさを取得
writesheet_last_row = optional_sheet.Cells(10,5).Value
If writesheet_last_row = 0 Then
'空欄だった場合、一番左の列から行数を推測
writesheet_last_row = writesheet.Cells(Rows.Count, 1).End(xlUp).Row
If writesheet_last_row = 0 Then
'推測もできなかった場合、100を設定
writesheet_last_row = 100
End If
End If
writesheet_last_column = optional_sheet.Cells(11,5).Value
If writesheet_last_column = 0 Then
'空欄だった場合、一番上の行から列数を推測
writesheet_last_column = writesheet.Cells(1, Columns.Count).End(xlToLeft).Column
If writesheet_last_column = 0 Then
'推測もできなかった場合、100を設定
writesheet_last_column = 100
End If
End If
'表名から入力対象列の開始を決定する
loop_readsheets_row = 1
loop_writesheets_column = 1
'読みこみ表名の書いてあるセルを記載する
For readtable_row_number = 1 To readsheet_last_row
For readtable_column_number = 1 To readsheet_last_column
If readsheet.Cells(readtable_row_number , readtable_column_number).Value = readsheet_tablename Then
readtablename_row = readtable_row_number
readtablename_column = readtable_column_number
'MsgBox "読み込み表名"& vbLf &"行:" & readtable_row_number & "、列：" & readtable_column_number
End If
Next readtable_column_number
Next readtable_row_number
'MsgBox "行:" & readtablename_row + loop_readsheets_row + 1 & vbLf & "、列：" & readtablename_column + readsheet_index_column
If readtablename_row + loop_readsheets_row + 1 >= 1 And readtablename_column + readsheet_index_column => 1 Then
'インデックス1の分だけ繰り返す(カラムはテーブルの行列を探す工程をスキップしている)
Do Until readsheet.Cells(readtablename_row + loop_readsheets_row + 1, readtablename_column + readsheet_index_column).Value = ""
writesheet_tablename = readsheet.Cells(readtablename_row + loop_readsheets_row + 1, readtablename_column + readsheet_index_column).Value
'MsgBox "読込対象行名"& vbLf &writesheet_tablename
writetablename_row = 0
writetablename_column =0
'読込対象のインデックスと同じ表名のかいてあるセルを検索する
For writetable_row_number = 1 To writesheet_last_row
For writetable_column_number = 1 To writesheet_last_column
If writesheet.Cells(writetable_row_number , writetable_column_number).Value = writesheet_tablename Then
writetablename_row = writetable_row_number
writetablename_column = writetable_column_number
'MsgBox "書込対象インデックス"& vbLf &"行:" & writetablename_row & vbLf & "列：" & writetablename_column
End If
Next writetable_column_number
Next writetable_row_number
'MsgBox "書込対象インデックス"& vbLf &"行:" & writetablename_row + writesheet_index_row & vbLf & "列：" & writetablename_column + writesheet_index_column + loop_writesheets_column
'読込対象行と同じ表名が存在するなら、書込み列を探す
If writetablename_row <> 0 And writetablename_column <> 0 Then
Do Until writesheet.Cells( writetablename_row + writesheet_index_row, writetablename_column + writesheet_index_column + loop_writesheets_column).Value = ""
'転記元にインデックス3と転記先インデックス3が同じ
If writesheet.Cells( writetablename_row + writesheet_index_row, writetablename_column + writesheet_index_column + loop_writesheets_column).Value = readsheet_tablename THEN
'MsgBox ("一致箇所が見つかりました。")
'MsgBox "一致箇所" & vbLf & "行:" & writetablename_row + writesheet_index_row & vbLf & "、列：" & writetablename_column + writesheet_index_column + loop_writesheets_column
loop_readsheets_column = 1
loop_writesheets_row = 1
'MsgBox "項目1" & vbLf &"読込ループ開始セル:" & vbLf &"行：" & readtablename_row + readsheet_index_row & vbLf & "列：" & readtablename_column + loop_readsheets_column + 1+ readsheet_index_column
'書込み元のインデックス2の分だけ繰り返す
Do Until readsheet.Cells(readtablename_row + readsheet_index_row, readtablename_column + loop_readsheets_column + readsheet_index_column).Value = ""
'書込み対象シートの全てのセルに対して繰り返す
Do Until writesheet.Cells( writetablename_row + writesheet_index_row + loop_writesheets_row, writetablename_column + writesheet_index_column).Value = ""
'書込み対象シートにインデックス2と同じ表名が存在している
If writesheet.Cells( writetablename_row + writesheet_index_row + loop_writesheets_row, writetablename_column + writesheet_index_column).Value = readsheet.Cells(readtablename_row + readsheet_index_row, readtablename_column + loop_readsheets_column + readsheet_index_column).Value THEN
'MsgBox ("一致箇所が見つかりました。")
'MsgBox "一致箇所" & vbLf & "行:" & writetablename_row + writesheet_index_row + loop_writesheets_row & vbLf & "、列：" & writetablename_column + writesheet_index_column
'値を転記する。
writesheet.Cells( writetablename_row + writesheet_index_row + loop_writesheets_row, writetablename_column + writesheet_index_column + loop_writesheets_column).Value = readsheet.Cells(readtablename_row + loop_readsheets_row + readsheet_index_row, readtablename_column + loop_readsheets_column + readsheet_index_column).Value
End If
loop_writesheets_row = loop_writesheets_row + 1
Loop
loop_writesheets_row = 1
'→転記元の表の列番号、転記先の表の行番号を取得する
loop_readsheets_column = loop_readsheets_column + 1
Loop
End If
loop_writesheets_column = loop_writesheets_column + 1
Loop
loop_writesheets_column = 1
End If
'→転記元の表の列番号、転記先の表の行番号を取得する
loop_readsheets_row = loop_readsheets_row + 1
Loop
Else
'転記元の表名に一致するものがない場合
MsgBox("表名、又はシートの読み込み範囲に誤りがあります。")
End If
End Sub問題ページに戻る