Excel VBAで実用ツール（一覧表作成編）

2022-01-192024-01-07

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

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

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

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

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

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

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

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

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

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

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

サンプル・プログラム

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

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

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

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

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

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

サンプル・プログラム

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

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

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

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

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

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

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

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

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

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

サンプル・プログラム

行番号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
7. Private Sub Sample3()
8.     Set dSht = ThisWorkbook.Worksheets(“データ定義")
9.     InFilePath = “C:\work\xxx.xlsx"
10.     InFileName = Dir(InFilePath)
11.     Workbooks.Open Filename:=InFilePath
12.     Workbooks.Add
13.     Set oSht = ActiveSheet
14.     Workbooks(InFileName).Worksheets(dSht.Cells(1, 1).Value).Rows(1).Copy
15.     oSht.Rows(1).PasteSpecial (xlPasteAll)
16.     ocnt = 1
18.     For i = 1 To dSht.Cells(dSht.Rows.Count, 1).End(xlUp).Row
19.         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
20.             If dSht.Cells(i, 2) = Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Cells(j, 1) Then
21.                 Exit For
22.             End If
23.         Next j
24.         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
25.             Workbooks(InFileName).Worksheets(dSht.Cells(i, 1).Value).Rows(j).Copy
26.             ocnt = ocnt + 1
27.             oSht.Rows(ocnt).PasteSpecial (xlPasteAll)
28.         End If
29.     Next i
31.     Workbooks(InFileName).Application.CutCopyMode = False
32.     Workbooks(InFileName).Close SaveChanges:=False
33. End Sub