何って…Excel VBAで個票を台帳に集約しただけ、だが？

このポエムはフィクションであり、実在の人物・団体とは一切関係ありません。

転生したら銀行員だった件

オレは銀行員で、今日から配属された新人ということらしい。配属先はシステム企画部だ。

それにしてもなにやら慌ただしい様子だ。というのも、2週間前に全国の支店に送った「システムの利用状況に関するアンケート」の結果（以下、アンケート結果）が今日一斉に返送されてきている。今はその集計作業でてんやわんやになっているのだとか。

アンケート結果はExcelファイルだ。ファイルサーバーに保存されたそれらを1個1個開いて、記載内容を別ファイルにコピー＆ペーストする作業を地道に行っている。こんなことをしていたら日が暮れてしまう。

Excel VBAでなんとかできないか？

Excel VBAでも使ったら、作る手間を含めても2時間もあればできるんじゃないか？　ずいぶん古臭いPCだが、Office365はインストールされている。

まずは1時間やってみて、話にならないようだったら手作業でやるという覚悟で臨む。そうでないと、マクロを作ることが目的になってしまう。あくまでも目的は業務を終わらせることだ。

アンケート結果が紙じゃなかったことがせめてもの救いだ。

時間ないから画面は適当で！

とりあえずマクロ用の入力画面を作る。セルに名前を付けておくのがポイントだな。

ブックを順番に開いて…と

ReadAndPaste()は後で作るとして、まずはファイルを順番に開く処理を作ってしまおう。

Do Whileの条件は再考の余地あり。これだとファイル名の一覧に空行があるとそこで処理が終了してしまう。

Sheet1

Public Sub Main()
    Dim InBook As Workbook
    Dim FolderName As Range
    Dim FileName As Range
    Dim Output As Range

    Set FolderName = Me.Range("フォルダ名")
    Set FileName = Me.Range("ファイル名").Offset(1)
    Set Output = ThisWorkbook.Worksheets("結果").Cells(1, 1)

    Do While Not IsEmpty(FileName.Value)
        ' Application.ScreenUpdating = False

        Set InBook = Workbooks.Open(FolderName.Value & FileName.Value)
        ' Call ReadAndPaste(InBook.Worksheets("アンケート"), Output)
        InBook.Close SaveChanges:=False

        ' Application.ScreenUpdating = True

        ' カーソルを1個下に進める
        Set FileName = FileName.Offset(1)
    Loop

    MsgBox "Done."
End Sub

おっ、動いた。いい感じだ。

値をコピー＆ペーストしてやれば…

ここは少々力技になるが、大したことはやっていない。

Find()がWhat:=の指定したキーワードで完全一致（XlLookAt.xlWhole）するセルを探しに行って、Offset(y, x)が下にy、右にx移動した先のセルを取得しているだけだ。この手のExcelで作られたフォームは 回答者が結構な確率で行や列を勝手に追加・削除してくる ので、座標指定で値を取得しに行くのはおすすめしない。

Sheet1

Private Sub ReadAndPaste(InSheet As Worksheet, Output As Range)
    Dim InRange As Range

    Set InRange = InSheet.Cells.Find(What:="部店名", LookAt:=XlLookAt.xlWhole).Offset(0, 1)
    Output.Value = InRange.Value

    Set InRange = InSheet.Cells.Find(What:="氏名", LookAt:=XlLookAt.xlWhole).Offset(0, 1)
    Output.Offset(0, 1).Value = InRange.Value

    Set InRange = InSheet.Cells.Find(What:="Q1. 部店で構築したツール類が本部システムAPIを呼び出す場合、", LookAt:=XlLookAt.xlWhole).Offset(2, 1)
    Output.Offset(0, 2).Value = InRange.Value

    Set InRange = InSheet.Cells.Find(What:="Q2. ツール類はどのような言語で作成されていますか？", LookAt:=XlLookAt.xlWhole).Offset(1, 1)
    Output.Offset(0, 3).Value = InRange.Value

    ' カーソルを1個下に進める
    Set Output = Output.Offset(1)
End Sub

ここのインターフェースはいろいろな考え方があって、値の取得と結果の書き出しはサブルーチンを別にした方がいい場合もある。今回は大したことはしていないので1個にまとめてしまう。

できた！

ボタンを付ける暇もなかったので、Alt+F8で実行する簡易的なものだ。ダイアログからSheet1!Mainを選択して実行する。

あなた…今何を…？

またオレ何かやっちゃいました？

何って…Excel VBAで個票を台帳に集約しただけ、だが？