ユーザ定義一覧表を作成するマクロ

複数のファイルから、特定のシートの特定のセルから値を抽出し、一覧表に纏めるマクロを紹介します。

画面はこうなります。

1.ファイル検索画面
対象ファイルを検索してから、「ユーザ定義一覧」にて、処理を始めます。

※埼玉県市区町村別の人口ファイル 

2.設定および処理結果一覧画面
抽出するシート名とセル名を指定します。セルは最大８つまで指定できます。

※市区町村別人口一覧の作成例 

ソースはこうなります。

'***************************************************
'画面の「ユーザ定義一覧」ボタンから呼び出される
'***************************************************
Sub UserDefineList()

    Dim objBook As Variant
    Dim objSheet As Variant 'シート
    Dim strFile As String
   
    Dim intRow As Integer
    Dim intLastRow As Integer
    Dim intLastTableRow As Integer
   
    Dim strCell1 As String
    Dim strCell2 As String
    Dim strCell3 As String
    Dim strCell4 As String
    Dim strCell5 As String
    Dim strCell6 As String
    Dim strCell7 As String
    Dim strCell8 As String

    If ThisWorkbook.Sheets(1).Range("D10").Value = "" Then Exit Sub
    If ThisWorkbook.Sheets("UserDefineList").Range("B2").Value = "" Then Exit Sub
 
    strCell1 = ThisWorkbook.Sheets("UserDefineList").Range("C2").Value
    strCell2 = ThisWorkbook.Sheets("UserDefineList").Range("D2").Value
    strCell3 = ThisWorkbook.Sheets("UserDefineList").Range("E2").Value
    strCell4 = ThisWorkbook.Sheets("UserDefineList").Range("F2").Value
    strCell5 = ThisWorkbook.Sheets("UserDefineList").Range("G2").Value
    strCell6 = ThisWorkbook.Sheets("UserDefineList").Range("H2").Value
    strCell7 = ThisWorkbook.Sheets("UserDefineList").Range("I2").Value
    strCell8 = ThisWorkbook.Sheets("UserDefineList").Range("J2").Value

    'ファイル一覧の最終行を求める
    intLastTableRow = ThisWorkbook.Sheets("UserDefineList").Range("B10000").End(xlUp).Row
 
    '既存の表のをクリアする
    intLastTableRow = ThisWorkbook.Sheets("UserDefineList").Range("B4").End(xlDown).Row
    If intLastTableRow > 4 Then
        ThisWorkbook.Sheets("UserDefineList").Range("B5:J" & intLastTableRow).Value = ""
        ThisWorkbook.Sheets("UserDefineList").Range("B5:J" & intLastTableRow).　_
                                                                    Borders.LineStyle = xlLineStyleNone
 
    End If

    '画面更新を無効にする
    Application.ScreenUpdating = False

 
    'メッセージ表示を無効にする
    Application.DisplayAlerts = False
 
    intRow = 4

    'ファイル毎の処理
    For i = 10 To intLastRow
   
        strFile = ThisWorkbook.Sheets(1).Cells(i, 4).Value

        If Right(strFile, 3) = "xls" Or Right(strFile, 4) = "xlsx" Then

            'ファイルをセットする
            Set objBook = Application.Workbooks.Open(strFile)
       
            'シート毎の処理
            For Each objSheet In objBook.Sheets
           
                If objSheet.Name = ThisWorkbook.Sheets("UserDefineList").Range("B2").Value Then
                 
                    intRow = intRow + 1
                 
                    ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 2).Value = objBook.Name
                 
                    '1列目
                    If strCell1 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 3).Value = _
                                                                       objSheet.Range(strCell1).Value
                    End If
                 
                    '2列目
                    If strCell2 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 4).Value = _
                                                                       objSheet.Range(strCell2).Value
                    End If
                 
                    '3列目
                    If strCell3 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 5).Value = _
                                                                       objSheet.Range(strCell3).Value
                    End If
                 
                    '4列目
                    If strCell4 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 6).Value = _
                                                                       objSheet.Range(strCell4).Value
                    End If
                 
                    '5列目
                    If strCell5 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 7).Value = _
                                                                       objSheet.Range(strCell5).Value
                    End If
                 
                    '6列目
                    If strCell6 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 8).Value = _
                                                                       objSheet.Range(strCell6).Value
                    End If
                 
                    '7列目
                    If strCell7 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 9).Value = _
                                                                       objSheet.Range(strCell7).Value
                    End If
                 
                    '8列目
                    If strCell8 <> "" Then
                        ThisWorkbook.Sheets("UserDefineList").Cells(intRow, 10).Value = _
                                                                       objSheet.Range(strCell8).Value
                    End If
                 
             
                Exit For
                End If
             
            Next objSheet
         
            '表に罫線をかける
            ThisWorkbook.Sheets("UserDefineList").Range("B4:J" & intRow). _
                                                          Borders.LineStyle = xlContinuous
       
            'ファイルクローズ
            objBook.Close savechanges:=False
               
        End If
       
    Next i

    'メッセージ表示を有効にする
    Application.DisplayAlerts = True

    '画面更新を有効に戻す
    Application.ScreenUpdating = True

    'シート処理結果をアクティブにする
    ThisWorkbook.Sheets("UserDefineList").Activate

    ' 処理完了(結果表示)
    MsgBox "処理が完了しました。"

End Sub

----------
以上