こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

EXCEL VBA

1月から3月までの12シートからなる複数のファイルがあります。
そのファイルを上書き保存したときに書式と値だけをコピーした「ファイル名+シート名」で別ファイルに保存をかけたいのです。
(例)
営業課月次.xlsの4月シートに入力をして、上書き保存をかけた時点で月次4月.xlsにシート名=営業課月次4月で書式と値だけ保存する。

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

投稿日時 - 2003-04-25 13:16:11

QNo.531743

困ってます

質問者が選んだベストアンサー

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

・新しいブックを開きます。
1行目に見出しとして
A1="部課ファイル名"  B1="月別月次ファイル作成月"
A2="営業課"      
A3="業務課"
A4="管理部門"
A5="支店"
  ・ (必ずファイル名と同じにします。.xlsは不要)
  ・ (中間に空白がないこと。あればその前で終わりと見なします。)
  ・
B2 には、集計する際、月数を入れますから、セルのバックに色を着け、
太線で囲むなどしてください。
C2="月分"

シートの準備は以上で、次にVBAの設定します。

・使用しているシートのシート名タブを右クリックして「コードの表示」を
 指定します。
・開いたコードウィンドウに下記コードをコピーして貼り付けます。
・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

投稿日時 - 2003-04-26 15:46:36

お礼

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

投稿日時 - 2003-04-28 10:19:53

ANo.3

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.2

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

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

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

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

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

投稿日時 - 2003-04-25 19:18:49

ANo.1

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

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

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

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

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

1.Alt + F11 で VBE(Visual Basic Editor)を開きます。
2.「プロジェクト」ウィンドウ(表示されていなかったらCtrl+R )で
  「ThisWorkbook」をダブルクリックします。
3.モジュールウィンドウに下記コードをコピーして貼り付けます。
4.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

投稿日時 - 2003-04-25 16:07:51

補足

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

投稿日時 - 2003-04-25 16:33:01

あなたにオススメの質問