EXCEL　VBA

次の通り操作してみてください。 ・新しいブックを開きます。 1行目に見出しとして A1="部課ファイル名"　　B1="月別月次ファイル作成月" A2="営業課"　　　　　　 A3="業務課" A4="管理部門" A5="支店" 　　・　（必ずファイル名と同じにします。.xlsは不要） 　　・　（中間に空白がないこと。あればその前で終わりと見なします。） 　　・ B2 には、集計する際、月数を入れますから、セルのバックに色を着け、 太線で囲むなどしてください。 C2="月分" シートの準備は以上で、次にＶＢＡの設定します。 ・使用しているシートのシート名タブを右クリックして「コードの表示」を 　指定します。 ・開いたコードウィンドウに下記コードをコピーして貼り付けます。 ・Alt+ Q (または、右上隅の×）でウィンドウを閉じ、シートに戻ります。 ・以上で設定完了です。　 集計の操作方法は、セルB2 に集計する 月を入力し<Enter>します。 入力した B2のセルを「ダブルクリック」すると集計を開始します。 ピッ となった後、完了のメッセージが出ますのでファイルを確認して ください。 「*月分」のファイルが出来て、各部課の月次シートが出来ています。 たぶん、このような集計を希望しているものと思います。 違う部分とかありましたら、その旨書き込んでみてください。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target _ 　　　　As Range, Cancel As Boolean) Dim Rng As Range Dim R As Range Dim Opbk As Workbook Dim Newbk As Workbook Dim Fpath As String Dim tuki As Integer Cancel = True If Target.Address <> "$B$2" Then Exit Sub tuki = Range("B2").Value If Not (tuki >= 1 And tuki <= 12) Then 　　MsgBox "月の指定が、正しくありません。", vbExclamation 　　Exit Sub End If Fpath = ThisWorkbook.Path & "\" Set R = Range("A2", Range("A2").End(xlDown)) Application.ScreenUpdating = False Application.DisplayAlerts = False Set Newbk = Workbooks.Add On Error Resume Next For Each Rng In R 　　Workbooks.Open Filename:=Fpath & Rng.Value & ".xls" 　　If Err.Number > 0 Then ' Err1004 　　　　MsgBox Rng.Value & _ 　　　　".xls のファイルが、見つかりません。", vbExclamation 　　　　Newbk.Close 　　　　Exit Sub ' Err.Clear 　　Else 　　　　Set Opbk = ActiveWorkbook 　　End If 　　Sheets(tuki & "月").Cells.Copy 　　If Err.Number > 0 Then ' Err9 　　　　MsgBox Rng.Value & ".xls に " & _ 　　　　StrConv(tuki, vbWide) & _ 　　　　　　"月 のシートが、見つかりません。", vbExclamation 　　　　Opbk.Close 　　　　Newbk.Close 　　　　Exit Sub ' Err.Clear 　　End If 　　Newbk.Activate 　　If Rng.Row = 2 Then 　　　　Sheets.Add before:=Worksheets(1) 　　Else 　　　　Sheets.Add after:=Worksheets(Rng.Row - 2) 　　End If 　　Selection.PasteSpecial Paste:=xlValues 　　Selection.PasteSpecial Paste:=xlFormats 　　ActiveSheet.Name = Rng.Value & tuki & "月" 　　ActiveSheet.Range("A1").Select 　　Opbk.Close Next Rng ActiveWorkbook.Sheets(1).Select ActiveWorkbook.SaveAs Fpath & tuki & "月" ActiveWorkbook.Close Beep Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox StrConv(tuki, vbWide) & _ 　　"月分の月次ファイルを作成しました。" Set R = Nothing Set Rng = Nothing Set Newbk = Nothing End Sub