ワークシート項目抽出マクロ

ここ数日、ExcelVBAのマクロを書いています。

Excelのシートで書かれた大量のアンケート、申請書などの項目を
全部一覧形式にしてチェックしたいときがしょっちゅうあります。

そんなときに使えるマクロを作ってみました。

Option Explicit

Sub データ抽出()
    Dim bkInput As Workbook
    Set bkInput = ThisWorkbook
    Dim shtInput As Worksheet
    Set shtInput = bkInput.Sheets(1)
    Dim bkOutput As Workbook
    Set bkOutput = Workbooks.Add
    shtInput.Copy Before:=bkOutput.Sheets(1)
    Dim shtOutput As Worksheet
    Set shtOutput = bkOutput.Sheets(1)
    
    Dim sPath As String
    Dim sBook As String
    Dim sSheet As String
    
    Dim nRow As Integer
    nRow = 2
    Do While shtOutput.Cells(nRow, 1) <> ""
        sPath = shtOutput.Cells(nRow, 1)
        sBook = shtOutput.Cells(nRow, 2)
        sSheet = shtOutput.Cells(nRow, 3)
        
        Dim bkData As Workbook
        Dim shtData As Worksheet
        
        Set bkData = Workbooks.Open(filename:=sPath & "\" & sBook, ReadOnly:=True)
        Set shtData = bkData.Worksheets(sSheet)
        
        Dim nCol As Integer
        nCol = 4
        Do While shtOutput.Cells(1, nCol) <> ""
            Dim sInputCell As String
            sInputCell = shtOutput.Cells(1, nCol)
            shtOutput.Cells(nRow, nCol) = shtData.Range(sInputCell)
            
            nCol = nCol + 1
        Loop

        bkData.Close

        nRow = nRow + 1
    Loop
    
End Sub

上記のマクロが記述されたBookと同一のBookのSheet1に、
以下のフォーマットで抽出対象のデータを記述します。

| ディレクトリ名                           | ブック名         | シート名   | D4 | D8 |
| D:\アンケート\01_Alloyによる設計検証講座 | アンケート_A.xls | アンケート |    |    |
| D:\アンケート\01_Alloyによる設計検証講座 | アンケート_B.xls | アンケート |    |    |
| D:\アンケート\01_Alloyによる設計検証講座 | アンケート_C.xls | アンケート |    |    |

A2:Anがディレクトリ名、
B2:Bnがブック名
C2:Cnがシート名です。
D1:a1のセルには、抽出したいセルのRangeを指定していきます。

こうやっておいて、「データ抽出」マクロを実行すると、
新しいブック上にデータを抽出してくれます。

これで、Alloy Analyzerの講座やCoqの講座をやるときに
何百人受講者が来ても困らなくなりました。

それにしてもハンガリアン記法なんて忘れましたよ。
http://www.vba-manners.info/0210_CodeRule/SysHungarian/index.html