選択したフォルダに含まれるExcelのファイルから，データを抽出するマクロです．
抽出した情報はマスタシートに書き出されます．
反対に，マスタシートから各ファイルへ書き込むこともできます．

目次

  1. ダウンロード
  2. 説明
  3. マクロ

ダウンロード

こちらからファイルをダウンロードできます．

説明

抽出する項目は，マスタシートの1行目に入っている各列の見出しに基づきます．
各ファイルでは，それぞれの見出しと対応する「セルの名前」を探し，存在すれば文字情報を抽出します．

「セルの名前」の入力場所「セルの名前」の入力場所

マスタシートの1列目はファイル名を記録するのに用いられますので，2列目以降の「セルの名前1」などを適宜書き換えてご使用ください．
使用される見出しの範囲は，右へ進み空白にあたるまでです．

書き込みは抽出の逆操作で，各ファイルに書き込みます．

マクロ

ダウンロードされるファイルのマクロは以下のようになっています．

Sub Macro1()
    Call Extractor(True)
End Sub

Sub Macro2()
    Call Extractor(False)
End Sub

Private Sub Extractor(ByVal extraction_mode As Boolean)
    
    Dim ws_mst_name As String
    ws_mst_name = ThisWorkbook.ActiveSheet.Range("ws_mst_name")
    
    Dim ws_template_name As String
    ws_template_name = ThisWorkbook.ActiveSheet.Range("ws_template_name")

    Dim ws_mst As Worksheet
    Set ws_mst = ThisWorkbook.Worksheets(ws_mst_name)

    Dim sep As String
    Dim filePath As String
    Dim fileName As String
    
    If Application.OperatingSystem Like "*Mac*" Then
        sep = "/"
    Else
        sep = "¥"
    End If
    
    Application.ScreenUpdating = False

    Dim dir_name As String
    dir_name = ChooseDir()
    
    filePath = dir_name & sep & "*.xls*"
    fileName = ""
    fileName = Dir(filePath)
    
    Dim i As Long
    i = 1
    ws_mst.Cells(i, 1) = "ファイル名"
    
    i = 2
    Do While fileName <> ""
        
        If fileName = ThisWorkbook.Name Then
            GoTo ContinueLabel
        End If
        
        If Not extraction_mode Then
            Do While ws_mst.Cells(i, 1) <> ""
                If fileName = ws_mst.Cells(i, 1) Then
                    GoTo BreakLabel
                End If
                i = i + 1
            Loop
            GoTo ContinueLabel
        End If
        
BreakLabel:
        
        filePath = dir_name & sep & fileName
        Workbooks.Open filePath
        
        Set wb = ActiveWorkbook
        Set ws = wb.Worksheets(ws_template_name)
        
        If extraction_mode Then
            ws_mst.Cells(i, 1) = wb.Name
        End If
        
        j = 2
        Do While ws_mst.Cells(1, j) <> ""
            mst_col_name = ws_mst.Cells(1, j)
            n_flg = False
            For Each n In wb.Names
                If n.Name = mst_col_name Then n_flg = True
            Next
            If n_flg And extraction_mode Then
                ws_mst.Cells(i, j) = ws.Range(mst_col_name)
            ElseIf n_flg And Not extraction_mode Then
                ws.Range(mst_col_name) = ws_mst.Cells(i, j)
            End If
            j = j + 1
        Loop
        
        ws_mst.Activate
        If extraction_mode Then
            wb.Close SaveChanges:=False
            i = i + 1
        Else
            wb.Close SaveChanges:=True
            i = 2
        End If
        
ContinueLabel:
        fileName = Dir()
        
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "マクロを実行しました．"
    
End Sub

Function ChooseDir()
    
    Dim cancel_msg As String
    cancel_msg = "キャンセルしました．"
    
    Dim dirPath As String
    If Application.OperatingSystem Like "*Mac*" Then
        dirPath = MacScript("try" & vbCrLf & "return posix path of (choose folder with prompt ""ディレクトリを選択してください．"") as string" & vbCrLf & "end try")
         If dirPath = "" Then
            MsgBox cancel_msg
            End
         End If
    Else
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = 0 Then
                MsgBox cancel_msg
                End
            End If
            dirPath = .SelectedItems(1) & "¥"
        End With
    End If
    ChooseDir = dirPath
    
End Function