同一シート内にある複数表を空白行、空白列を変えて転記,又は分割する
プログラムの運用でデ一タを整理しているときに、表の体裁を変えて保存し直したいという状況に陥った。1つや2つなら何とかなるが、数が多くなった結果空白行や空白列の体裁を変更するツ一ルを作成したので情報共有する。
ソースコード
ソースコードは下記の通り
Sub spread_between_tables()
'----------------------------------------------
'概要:同一シート内にある複数表を空白行、空白列を変えて転記,又は分割する
'機能名:spread_between_tables
'引数:なし
'戻り値:なし
'備考:なし
-------------------------------------------
Dim readsheet As Worksheet
Dim writesheet As Worksheet
Dim optional_sheet As Worksheet
Dim readbook_name As String
Dim writebook_name As String
Dim writebook_name_2 As String
Dim readsheet_name As String
Dim writesheet_name As String
Dim writesheet_name_1 As String
Dim writesheet_name_2 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_row_number As Integer
Dim writesheet_row_number As Integer
Dim Sheet_number As Integer
Dim sheet_kosu As Integer
Dim koumoku_kosu As Integer
Dim orikaeshi_kosu As Integer
Dim start_row As Integer
Dim start_column As Integer
Dim end_row As Integer
Dim end_column As Integer
Dim read_column_blanc As string
Dim write_column_blanc As string
Dim read_row_blanc As string
Dim write_row_blanc As string
Dim date_l As string
Dim yokohaba As Integer
Dim tatehaba As Integer
Set optional_sheet = Worksheets("マクロ実行シート")
'3行目：ファイルパス
myPath = optional_sheet.Cells(3, 4).Value
'4行目：読込みブック名
readbook_name = optional_sheet.Cells(4, 4).Value
'5行目：読み込みシート名
readsheet_name =optional_sheet.Cells(5, 4).Value
'6行目：転記先ブック名
writebook_name = optional_sheet.Cells(6, 4).Value
'転記先ブック名2つ目
writebook_name_2 = optional_sheet.Cells(6, 5).Value
'書込みシート数(1か2のみ対応)
sheet_kosu = optional_sheet.Cells(7, 4).Value
'8,9行目：書込みシート名
writesheet_name_1 = optional_sheet.Cells(8, 4).Value
writesheet_name_2 = optional_sheet.Cells(9, 4).Value
writesheet_name = writesheet_name_1
'10行目：項目の個数
koumoku_kosu = optional_sheet.Cells(10, 4).Value
'11行目：折り返しの対象にする個数
orikaeshi_kosu = optional_sheet.Cells(11, 4).Value
'12行目：1項目目転記開始行
start_row = optional_sheet.Cells(12, 4).Value
'13行目：1項目目転記開始列
start_column = optional_sheet.Cells(13, 4).Value
'14行目：1項目目転記終了行
end_row = optional_sheet.Cells(14, 4).Value
'15行目：1項目目転記終了列
end_column = optional_sheet.Cells(15, 4).Value
'16行目：読込項目間の空白列
read_column_blanc = optional_sheet.Cells(16, 4).Value
'17行目：書込項目間の空白列
write_column_blanc = optional_sheet.Cells(17, 4).Value
'18行目：読込項目間の空白行
read_row_blanc = optional_sheet.Cells(18, 4).Value
'19行目：書込項目間の空白行
write_row_blanc = optional_sheet.Cells(19, 4).Value
'20行目：記載する年月日
date_l = optional_sheet.Cells(20, 4).Value
'アラート表示OFF
Application.DisplayAlerts = False
'ファイル名のブックを開く
Workbooks.Open myPath & "\" & readbook_name
Workbooks.Open myPath & "\" & writebook_name
Workbooks.Open myPath & "\" & writebook_name_2
Set readsheet = Workbooks(readbook_name).Worksheets(readsheet_name)
Set writesheet = Workbooks(writebook_name).Worksheets(writesheet_name)
write_yokohaba = end_column - start_column + write_column_blanc
write_tatehaba = end_row - start_row + write_row_blanc
read_yokohaba = end_column - start_column + read_column_blanc + 1
read_tatehaba = end_row - start_row + read_row_blanc + 1
'該当部分をコピーする
For Sheet_number = 0 To sheet_kosu - 1
'A1のセルの値を指定された年月日に指定
writesheet.Cells(1, 1).Value = date_l
'1号機から3号機までの部分をまとめてコピー
'セルコピー対象
'B3～F26:cell(3,2)～cell(3+23,2+4)
'J3～N26:cell(3,2+8)～cell(3+23,2+4+8)
'R3～V26:cell(3,2+8*2)～cell(3+23,2+4+8*2)
'B31～F54:cell(3+28,2)～cell(3+23,2+4)
'J31～N54:cell(3+28,2+8)～cell(3+23,2+4+8)
'R31～V54:cell(3+28,2+8*2)～cell(3+23,2+4+8*2)
For Komoku_number = 0 To koumoku_kosu
For writesheet_row_number = start_row To end_row
For writesheet_contents_column = start_column To end_column
table_tate_count = Komoku_number / orikaeshi_kosu
table_yoko_count = Komoku_number Mod orikaeshi_kosu
writesheet.Cells(writesheet_row_number + (table_tate_count * write_tatehaba), writesheet_contents_column + (table_yoko_count * write_yokohaba)).Value = readsheet.Cells(writesheet_row_number + (table_tate_count * read_tatehaba), writesheet_contents_column + (Sheet_number * read_yokohaba) + (table_yoko_count * read_yokohaba * sheet_kosu)).Value
Next writesheet_contents_column
Next writesheet_row_number
Next Komoku_number
'------------------------------------------Start：状況に応じて、コピー後にマクロを実施する-------------------------------------------
'------------------------------------------End：状況に応じて、コピー後にマクロを実施する------------------------------------------------
If Sheet_number = 0 And 1 < Sheet_kosu Then
'シート名変更
writesheet_name = writesheet_name_2
'各ワークシートの変更
Set writesheet = Workbooks(writebook_name).Worksheets(writesheet_name)
End If
Next Sheet_number
'ブックを保存せずに閉じる
Workbooks(readbook_name).Close SaveChanges:=False
Workbooks(writebook_name).Close SaveChanges:=True
Workbooks(writebook_name_2).Close SaveChanges:=True
End Sub