下記前提でいいのであれば、提示コードのようなものでしょうか？ 前提が違っているようなら、あきらめてください。 その場合は、ごめんなさい <m(__)m> ・集約用のマクロファイルを作成します。その中に、提示のコードを作成してください。 ・集計マクロがあるフォルダーに「実績」と「集約」のフォルダを作成します。フォルダー名は固定です。 ・「実績」フォルダー直下に全支社EXCELブックを保存します。サブフォルダーは使用できません。 ・「集約」フォルダー直下に支店ブックを作成します。 ・「支店名」はユニークである前提です。 ・２度ブックを開いているなどが、シリアル処理なのでレスポンスは期待しないでください。遅いということです（多分）。 ・集約用のマクロファイルに一旦、作業用シートを作成しています。 ・その他、いろいろあるかもしれません。再度になりますが、使用できないようでしたら、あきらめてください。 ・「Private Sub CommandButton1_Click()」はACTIVEXのボタンの場合です。実施方法が違う場合は、実施環境にあわせてください。 Private Sub CommandButton1_Click() Const sBaseSheetName As String = "☆開始" Dim MyWb As Workbook, MyWs As Worksheet, wk As Worksheet Dim NewWb As Workbook Dim ii As Long ''現状の環境を保存する。 Set MyWb = ThisWorkbook Set MyWs = ActiveSheet sBookPath = ThisWorkbook.Path & "\実績\" ''作業シートを作成し、一旦、「支店名」「支社名」を取得する。 Application.ScreenUpdating = False Set wk = MaKeWorksheet(True) ''一覧表から支店単位に支社を集約する。 Application.SheetsInNewWorkbook = 1 Set NewWb = Nothing For ii = 1 To wk.Cells(wk.Rows.CountLarge, "A").End(xlUp).Row If NewWb Is Nothing Then Set NewWb = Workbooks.Add NewWb.Sheets(1).Name = sBaseSheetName End If ''支店分のシートを追加する。念のため、値貼り付けにする。 With Workbooks.Open(wk.Cells(ii, "A").Value, 0, True) With .Sheets(1) .Copy after:=NewWb.Sheets(NewWb.Sheets.Count) .Cells.Copy ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = True End With ActiveSheet.Range("A1").Select ''おまじない ActiveSheet.Name = wk.Cells(ii, "C").Value Application.DisplayAlerts = False .Close SaveChanges:=False Application.DisplayAlerts = True End With If wk.Cells(ii, "B").Value <> wk.Cells(ii + 1, "B").Value Then Application.DisplayAlerts = False NewWb.Sheets(sBaseSheetName).Delete NewWb.SaveAs ThisWorkbook.Path & "\集約\" & wk.Cells(ii, "B").Value & ".xlsx", _ FileFormat:=xlOpenXMLWorkbook NewWb.Close SaveChanges:=False Application.DisplayAlerts = True Set NewWb = Nothing End If Next ii ''作業シートの削除と変数を開放する。 Set wk = MaKeWorksheet(False) MyWs.Activate Application.ScreenUpdating = True Set MyWs = Nothing Set MyWb = Nothing End Sub Private Function MaKeWorksheet(ByVal bMake As Boolean) As Worksheet Const sWorkSheetName As String = "☆実績" Dim sBookPath As String, sBookName As String, iBookRow As Long ''作業シートがあれば削除する。 Set MaKeWorksheet = Nothing On Error Resume Next Application.DisplayAlerts = False Worksheets(sWorkSheetName).Delete Application.DisplayAlerts = True On Error GoTo 0 ''作業シートを作成する。 If bMake = True Then Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ActiveSheet.Name = sWorkSheetName Set MaKeWorksheet = ActiveSheet ''「支店名」「支社名」を取得する。 sBookPath = ThisWorkbook.Path & "\実績\" sBookName = Dir(sBookPath & "*.xls*", vbNormal) iBookRow = 0 Do While sBookName <> "" iBookRow = iBookRow + 1 MaKeWorksheet.Cells(iBookRow, "A").Value = sBookPath & sBookName With Workbooks.Open(sBookPath & sBookName, 0, True) MaKeWorksheet.Cells(iBookRow, "B").Value = .Sheets(1).Range("A1").Value MaKeWorksheet.Cells(iBookRow, "C").Value = .Sheets(1).Range("B1").Value .Close SaveChanges:=False End With sBookName = Dir() Loop ''「支店名」でソートする。 With MaKeWorksheet.Sort .SortFields.Clear .SortFields.Add2 Key:=MaKeWorksheet.Range("B1").Resize(iBookRow), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange Range("A1").Resize(iBookRow, 4) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlStroke .Apply End With End If End Function ※ご留意 Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ActiveSheet.Name = sWorkSheetName は２行です。掲示板の仕様（？）で１行になるかもしれません。他にもあるかもしれません。