全部抜き出すので、かえって漏れがなくなるようにしてある。フォルダを選んで、その中にあるエクセルファイルすべてから「実績概要」を抜き出せる。

Option Explicit

Sub 実績概要_空行以外すべて抽出()

    Dim folderPath As String
    Dim fileName As String
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    Dim wsOut As Worksheet
    Dim outRow As Long
    Dim srcRow As Long
    Dim srcCol As Long
    Dim lastRow As Long
    Dim bukaiName As String
    Dim sectionName As String
    Dim hasData As Boolean
    Dim colOut As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    ' 出力シート
    On Error Resume Next
    Set wsOut = ThisWorkbook.Worksheets("一覧")
    On Error GoTo 0
    
    If wsOut Is Nothing Then
        Set wsOut = ThisWorkbook.Worksheets.Add
        wsOut.Name = "一覧"
    Else
        wsOut.Cells.Clear
    End If

    ' 見出し
    wsOut.Cells(1, 1).Value = "ファイル名"
    wsOut.Cells(1, 2).Value = "部会"
    wsOut.Cells(1, 3).Value = "元行"
    wsOut.Cells(1, 4).Value = "区分"
    
    colOut = 5
    For srcCol = 2 To 27   ' B～AA
        wsOut.Cells(1, colOut).Value = Split(Cells(1, srcCol).Address(False, False), "$")(0) & "列"
        colOut = colOut + 1
    Next srcCol

    outRow = 2

    ' フォルダ選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "22個のExcelファイルが入っているフォルダを選んでください"
        If .Show <> -1 Then
            MsgBox "キャンセルされました。"
            GoTo ExitProc
        End If
        folderPath = .SelectedItems(1) & "\"
    End With

    fileName = Dir(folderPath & "*.xls*")

    Do While fileName <> ""

        If folderPath & fileName <> ThisWorkbook.FullName Then
        
            Set wbSrc = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
            
            On Error Resume Next
            Set wsSrc = wbSrc.Worksheets("３実績概要")
            On Error GoTo 0
            
            If Not wsSrc Is Nothing Then
                
                ' 部会名
                bukaiName = Trim(CStr(wsSrc.Range("U2").Value))
                
                ' 最終行（B～AAのどこかに値がある最大行）
                lastRow = 1
                For srcCol = 2 To 27
                    If wsSrc.Cells(wsSrc.Rows.Count, srcCol).End(xlUp).Row > lastRow Then
                        lastRow = wsSrc.Cells(wsSrc.Rows.Count, srcCol).End(xlUp).Row
                    End If
                Next srcCol
                
                sectionName = ""
                
                For srcRow = 1 To lastRow
                    
                    ' 区分名を保持
                    If Trim(CStr(wsSrc.Cells(srcRow, 2).Value)) <> "" Then
                        Select Case Trim(CStr(wsSrc.Cells(srcRow, 2).Value))
                            Case "研究大会及び研修会", "研究調査", "研究用図書購入", "研究成果の刊行"
                                sectionName = Trim(CStr(wsSrc.Cells(srcRow, 2).Value))
                        End Select
                    End If
                    
                    ' B～AAのどこかに値があるか
                    hasData = False
                    For srcCol = 2 To 27
                        If Trim(CStr(wsSrc.Cells(srcRow, srcCol).Value)) <> "" Then
                            hasData = True
                            Exit For
                        End If
                    Next srcCol
                    
                    ' 空行以外はすべて出力
                    If hasData Then
                        wsOut.Cells(outRow, 1).Value = fileName
                        wsOut.Cells(outRow, 2).Value = bukaiName
                        wsOut.Cells(outRow, 3).Value = srcRow
                        wsOut.Cells(outRow, 4).Value = sectionName
                        
                        colOut = 5
                        For srcCol = 2 To 27   ' B～AA
                            wsOut.Cells(outRow, colOut).Value = wsSrc.Cells(srcRow, srcCol).Value
                            colOut = colOut + 1
                        Next srcCol
                        
                        outRow = outRow + 1
                    End If
                    
                Next srcRow
                
            End If
            
            wbSrc.Close SaveChanges:=False
            Set wsSrc = Nothing
        End If

        fileName = Dir()
    Loop

    ' 体裁
    With wsOut
        .Rows(1).Font.Bold = True
        .Rows(1).Interior.Color = RGB(217, 225, 242)
        .Rows(1).WrapText = False
        .Columns.AutoFit
        
        With .Range("A1").CurrentRegion
            .Borders.LineStyle = xlContinuous
        End With
    End With

    MsgBox "空行以外の行をすべて抽出しました。"

ExitProc:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

① 新しいExcelを作る

まず新しいファイルを作ります。

実績一覧.xlsm

※ .xlsm（マクロ有効ブック） にするのが重要です。

保存するとき

ファイルの種類
↓
Excelマクロ有効ブック (*.xlsm)

を選びます。

② VBA画面を開く

キーボードで

Alt + F11

すると VBAエディタ が開きます。

③ モジュールを作る

左側にこのようなツリーがあります。

VBAProject (実績一覧.xlsm)

それを右クリックします。

挿入
↓
標準モジュール

すると

Module1

という白い画面が出ます。

④ マクロを貼る

その白い画面に

下記のマクロ全部を貼り付けます。

Sub 実績概要を一覧表にまとめる()
    ～
End Sub

⑤ 保存

Ctrl + S

で保存。

⑥ マクロを実行

Excel画面に戻って

Alt + F8

押します。

すると

実績概要を一覧表にまとめる

というマクロが出るので

実行

を押します。

⑦ フォルダを選ぶ

すると

22ファイルが入っているフォルダ

を選ぶ画面が出ます。

そこを選ぶと

自動で

一覧シート

に全部まとめられます。

完成イメージ