EXCEL VBA

質問

１月から３月までの１２シートからなる複数のファイルがあります。
そのファイルを上書き保存したときに書式と値だけをコピーした「ファイル名＋シート名」で別ファイルに保存をかけたいのです。
（例）
営業課月次.xlsの４月シートに入力をして、上書き保存をかけた時点で月次４月.xlsにシート名＝営業課月次４月で書式と値だけ保存する。

こんな都合のよいVBAがありましたら教えていただきたいと思います。宜しくお願いします。
（VBAに関しては入門編ぐらいの知識しかありません。）

回答No.3

ja7awu · ベストアンサー

次の通り操作してみてください。

・新しいブックを開きます。
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

お礼

お礼の返事が遅くなり申し訳ありません。
なんてお礼をいったらいいのか分からないぐらい感動しています。そうです！これがやりたかったんです！すごすぎます！
今まで毎月手作業でシートのコピーをかけていたんです。うれしくて今も顔がニヤけたまんまです。
今の私にはこのVBAが解読できませんが、少しずつ覚えたいと思っています。
本当に、本当にありがとうございました。m(_ _)m

回答No.2

ja7awu

なるほど・・・そうですか。(例)に頼りましたからね。

「各ファイルから同じ月のシートを集めて１個のファイルを作る」という
ことですよね。

それでは、「ファイルを上書き保存したときに実行」というのは、
意味がなくダメだと思います。
他のファイルからも持ってこないとダメですから・・・
あと、何も４月分だけ という訳じぁないんですよね。

ひとつの案ですが、例えば「月別月次作成.xls」を作り、ここに
A列に部課名一覧を作り、テキストボックスとコマンドボタンを各１個
配置し、テキストボックスに何月分かを入れ、コマンドボタンを押すと
その月の月次ファイルが出来るというのは、どうでしょうか。
部課名一覧がないとちょっと大変です。ファイル名からも出来ないことは
ないですが、手間がかかります。

こんな感じでどうでしょうか。
ちょっと時間が掛かりますね。

回答No.1

ja7awu

次のようなコードで如何でしょうか。

１ヶ所でも変更が、あると全シート分のブックを上書きします。

日付/時刻関数を使用していると、開いてから何も内容を変更しなくても
各シート毎のファイルは、１回は上書されます。

各シート毎のファイルは、基のブックと同じフォルダに作成されます。

ご存知かも知れませんが、一応コード設定方法を書いておきます。

１．Alt + F11 で VBE(Visual Basic Editor)を開きます。
２．「プロジェクト」ウィンドウ（表示されていなかったらCtrl+R ）で
　　「ThisWorkbook」をダブルクリックします。
３．モジュールウィンドウに下記コードをコピーして貼り付けます。
４．Alt + Q （または、右上隅の×）でウィンドウを閉じ、シートに戻ります。
以上で設定終わりです。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Newbk As Workbook
Dim Bkn As String
Dim Shn As String
Dim N As Integer
If ActiveWorkbook.Saved = True Then Exit Sub
Shn = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For N = 1 To Worksheets.Count
　　Bkn = "月次" & Sheets(N).Name & ".xls"
　　Sheets(N).Cells.Copy
　　Set Newbk = Workbooks.Add
　　Cells.PasteSpecial Paste:=xlValues
　　Cells.PasteSpecial Paste:=xlFormats
　　Newbk.Sheets(1).Name = Shn & Sheets(N).Name
　　Range("A1").Select
　　ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Bkn
　　ActiveWorkbook.Close
Next N
Beep
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Newbk = Nothing
End Sub

補足

たった今実行しました。感動です。ありがとうございます。
でも私の説明が悪かったです。
営業課月次.xls
業務課.xls
管理部門.xls
支店.xls・・・・（まだ続く）
と各部門ごとに１２ヵ月のシートがありまして、シートの４月分を月次４月.xlsのシートに全部並べて保存したいのです。つまり、４月.xlsには
営業課月次４月
業務課月次４月
管理部門月次４月
支店月次４月・・・・とシートが並ぶような感じです。
説明が下手で申し訳ないです。
宜しくお願いします。