Excel VBAで実用ツール(一覧表作成編)

2024-01-07

■複数の単票を基に一覧表を作成するツール

単票形式のファイルをまとめて一覧表にしたいとき、入力ファイルと出力ファイルの各項目の位置をExcelシートに入れてしまえば、非常に簡単なプログラムでデータを転記できます。
次項で紹介する方式であれば、短時間で一覧表を作成できますので、是非お試し下さい。

単票ファイルと一覧表ファイルのフォーマット

サンプル・プログラムで使用する単票ファイルは、「基本」シートと「詳細」シートの2シート構成になっており、「基本」シートには「氏名」「所属」「職位」「電話番号」「メールアドレス」を保有、「詳細」シートには「属性01」~「属性20」の20項目を保有しています。

(単票ファイル-「基本」シートのイメージ)

氏名
所属
職位
電話番号
メールアドレス

(単票ファイル-「詳細」シートのイメージ)

属性01
属性02
・・・
属性20

一覧表ファイルは、単純に全項目を横に並べた形式です。

(一覧表ファイルのイメージ)

氏名 所属 職位 電話番号 メールアドレス 属性01 属性02 ・・・ 属性20

サンプル・プログラムの「データ定義」シート

「データ定義」シートは、A列に単票ファイルの「シート名」、B列に入力元データの「セル位置」、C列に一覧表ファイルの「見出し項目名」、D列に出力先データの「列」を入力します。

(「データ定義」シートの内容)

基本 C2 氏名 A
基本 C3 所属 B
基本 C4 職位 C
基本 C7 電話番号 D
基本 C8 メールアドレス E
詳細 B1 属性01 F
詳細 B2 属性02 G
・・・
詳細 B20 属性20 Y

サンプル・プログラム

行番号9で新しいワークブックを開き、行番号12~14で「データ定義」シートから項目見出しをセットし、行番号15~19で項目見出しを編集(背景色を灰色に設定し、文字を太字にして中央寄せ)しています。
行番号21で単票ファイルを格納しているフォルダを変数にセットし、行番号22で最初の単票ファイルのファイル名を取得して、行番号23~31の繰返し処理に入ります。
行番号25で単票ファイルをオープンし、行番号26~28でデータを転送した後、行番号29で単票ファイルをクローズ。行番号30で次の単票ファイルのファイル名を取得し、ファイル名が空値になったらループを抜けます。
(「データ定義」シートに従って、データを転送する処理は行番号27だけです)
ループを抜けた後の行番号33は、一覧表全体に罫線を引いています。
なお、行番号27で「データ定義」シートの情報を基にWorksheetsオブジェクトのシート名を指定する際、「dSht.Cells(i, 1).Value」として明示的にValueプロパティを指定していますが、このように記述しないと実行時エラーになります。

  1. Dim dSht, oSht As Object
  2. Dim InFolderPath As String
  3. Dim InFileName As String
  4. Dim ocnt As Integer
  5. Dim i As Integer
  6. Private Sub Sample1()
  7.     Set dSht = ThisWorkbook.Worksheets(“データ定義")
  8.     Workbooks.Add
  9.     Set oSht = ActiveSheet
  10.     ocnt = 1
  11.     For i = 1 To dSht.Cells(dSht.Rows.Count, 3).End(xlUp).Row
  12.         oSht.Cells(ocnt, i) = dSht.Cells(i, 3)
  13.     Next i
  14.     With oSht.UsedRange
  15.         .Interior.Color = RGB(127, 127, 127)
  16.         .Font.Bold = True
  17.         .HorizontalAlignment = xlCenter
  18.     End With
  19.     InFolderPath = “C:\work\単票フォルダ"
  20.     InFileName = Dir(InFolderPath & “\*.xlsx")
  21.     Do While InFileName <> “"
  22.         ocnt = ocnt + 1
  23.         Workbooks.Open Filename:=InFolderPath & “\" & InFileName, UpdateLinks:=False
  24.         For i = 1 To dSht.Cells(dSht.Rows.Count, 1).End(xlUp).Row
  25.             oSht.Range(dSht.Cells(i, 4) & ocnt) = Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Range(dSht.Cells(i, 2))
  26.         Next i
  27.         Workbooks(InFileName).Close SaveChanges:=False
  28.         InFileName = Dir()
  29.     Loop
  30.     oSht.UsedRange.Borders.LineStyle = xlContinuous
  31. End Sub

■項目数の多い一覧表を折返して表示するツール

一覧表ファイルの項目数が多く、横に長~い形式になって見辛いとき、項目を折返して見易く整形するツールですが、基本的には項目をカット&ペーストするだけなので、非常に簡単なプログラムです。

一覧表ファイル(整形後)のフォーマット

前項のサンプル・プログラムで作成した一覧表ファイルを3段に折返して表示することにします。
「氏名」「所属」をキー項目として全ての行の左端に表示し、1列空けて残りの項目を表示し、1段目には「基本」シートの残りの項目(「職位」「電話番号」「メールアドレス」)、2~3段目には「詳細」シートの「属性xx」を10項目ずつ表示する仕様です。

(一覧表ファイル(整形後)のイメージ)

氏名 所属 職位 電話番号 メールアドレス
氏名 所属 属性01 属性02 ・・・ 属性10
氏名 所属 属性11 属性12 ・・・ 属性20

サンプル・プログラム

行番号9で一覧表ファイルをオープン、行番号11で新しいワークブックを開き、行番号13で一覧表ファイルの内容を新しいワークシートにコピーし、行番号14で元の一覧表ファイルをクローズしています(元の一覧表ファイルを直接更新しないようにしています)。
行番号16~25で後続の処理で使用する変数に値を設定していますが、各変数の意味は下表の通りです(汎用的なプログラムではありませんが、変数にセットする値を変えるだけで、ある程度のアレンジが可能です)。

変数名 内容
行数 元ファイルの行数
列数 元ファイルの列数
キー項目数 整形後ファイルのキー項目数
表示項目数 整形後ファイルの2段目以降の表示項目数
先頭セル 整形後ファイルの2段目に表示する項目の先頭位置

行番号27で1段目の編集(キー項目の後ろに1列空けているだけ)を行い、行番号28~34の繰返し処理が2段目以降の処理になっており、行番号30でキー項目をコピー&ペーストし、行番号31で表示項目数分のセルをカット&ペーストしています。

  1. Dim iSht, oSht As Object
  2. Dim InFolderPath As String
  3. Dim InFileName As String
  4. Dim ocnt, 行数, 列数, キー項目数, 表示項目数, 先頭セル, 段数, i As Integer
  5. Private Sub Sample2()
  6.     InFolderPath = “C:\work"
  7.     InFileName = “一覧表.xlsx"
  8.     Workbooks.Open Filename:=InFolderPath & “\" & InFileName, UpdateLinks:=False
  9.     Set iSht = ActiveSheet
  10.     Workbooks.Add
  11.     Set oSht = ActiveSheet
  12.     iSht.UsedRange.Copy oSht.Range(“A1")
  13.     Workbooks(InFileName).Close SaveChanges:=False
  14.     行数 = oSht.Cells(oSht.Rows.Count, 1).End(xlUp).Row
  15.     列数 = oSht.Cells(1, oSht.Columns.Count).End(xlToLeft).Column
  16.     キー項目数 = 2
  17.     表示項目数 = 10
  18.     先頭セル = 7
  19.     段数 = (列数 – キー項目数 – 表示項目数) / 表示項目数
  20.     If ((列数 – キー項目数) Mod 表示項目数) > 0 Then
  21.         段数 = 段数 + 1
  22.     End If
  23.     ocnt = 行数
  24.     oSht.Range(oSht.Cells(1, キー項目数 + 1), oSht.Cells(行数 + 1, 列数)).Cut Destination:=oSht.Cells(1, キー項目数 + 2)
  25.     For i = 1 To 段数
  26.         ocnt = ocnt + 2
  27.         oSht.Range(oSht.Cells(1, 1), oSht.Cells(行数 + 1, キー項目数)).Copy Destination:=oSht.Cells(ocnt, 1)
  28.         oSht.Range(oSht.Cells(1, 先頭セル), oSht.Cells(行数 + 1, 先頭セル + 表示項目数 – 1)).Cut Destination:=oSht.Cells(ocnt, キー項目数 + 2)
  29.         ocnt = ocnt + 行数 – 1
  30.         先頭セル = 先頭セル + 表示項目数
  31.     Next i
  32. End Sub

■複数の一覧表をマージしながら明細行を並べ替えるツール

複数の一覧表をマージして1つの一覧表にするついでに、関連する明細行が1箇所に固まるように並べ替えたかったことがあり、手作業だとかなり手間が掛るので、最初に挙げたサンプル・プログラムを改造して簡単なツールを作りました。
元の一覧表に「№」欄を設け、「データ定義」シートに並べたい順に№を書いておき、プログラムで該当行を探して行単位にコピーするという、非常に簡単なプログラムです。

一覧表ファイルのフォーマット

説明の都合上、基本的には前掲の一覧表と同じフォーマットにして、先頭に「№」を追加しています。

(一覧表ファイルのイメージ)

氏名 所属 職位 電話番号 メールアドレス 属性01 属性02 ・・・ 属性20

サンプル・プログラムの「データ定義」シート

「データ定義」シートは、A列に入力ファイルの「シート名」、B列に入力元データの「№」を入力します。

(「データ定義」シートの内容)

Sheet2 101
Sheet1 1
Sheet1 8
Sheet1 9
Sheet1 10
Sheet1 2
Sheet2 102
・・・ ・・・
Sheet2 106

サンプル・プログラム

行番号11で入力ファイル、行番号12で新しいワークブックを開き、行番号14~15で見出し行をコピーした後、行番号18~29の繰返し処理で「データ定義」シートに従って、該当行をコピーしています。
行番号19~23で「データ定義」シートで定義された「シート名」「№」に該当する明細行を探し、行番号24~28でみつかった明細行を出力ファイルにコピーしています。
なお、行番号14、19、20、24、25で「データ定義」シートの情報を基にWorksheetsオブジェクトのシート名を指定する際、「dSht.Cells(i, 1).Value」として明示的にValueプロパティを指定していますが、このように記述しないと実行時エラーになります。

  1. Dim dSht, oSht As Object
  2. Dim InFilePath As String
  3. Dim InFileName As String
  4. Dim ocnt As Integer
  5. Dim i, j As Integer
  6. Private Sub Sample3()
  7.     Set dSht = ThisWorkbook.Worksheets(“データ定義")
  8.     InFilePath = “C:\work\xxx.xlsx"
  9.     InFileName = Dir(InFilePath)
  10.     Workbooks.Open Filename:=InFilePath
  11.     Workbooks.Add
  12.     Set oSht = ActiveSheet
  13.     Workbooks(InFileName).Worksheets(dSht.Cells(1, 1).Value).Rows(1).Copy
  14.     oSht.Rows(1).PasteSpecial (xlPasteAll)
  15.     ocnt = 1
  16.     For i = 1 To dSht.Cells(dSht.Rows.Count, 1).End(xlUp).Row
  17.         For j = 2 To Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Cells(Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Rows.Count, 1).End(xlUp).Row
  18.             If dSht.Cells(i, 2) = Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Cells(j, 1) Then
  19.                 Exit For
  20.             End If
  21.         Next j
  22.         If j <= Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Cells(Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Rows.Count, 1).End(xlUp).Row Then
  23.             Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Rows(j).Copy
  24.             ocnt = ocnt + 1
  25.             oSht.Rows(ocnt).PasteSpecial (xlPasteAll)
  26.         End If
  27.     Next i
  28.     Workbooks(InFileName).Application.CutCopyMode = False
  29.     Workbooks(InFileName).Close SaveChanges:=False
  30. End Sub

国本温子(著),緑川吉行(著),できるシリーズ編集部(著)
出版社:インプレス
発売日:2022/3/23
単行本(ソフトカバー):A5判/912ページ

大村あつし(著),古川順平(著)
出版社:技術評論社
発売日:2021/1/9
単行本(ソフトカバー):A5判/800ページ

高橋宣成(著)
出版社:技術評論社
発売日:2019/11/25
単行本(ソフトカバー):B5変形判/576ページ

実用ツール

Posted by hides