エクセルVBAでファイル作成

質問

エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。
しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。
処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか？
最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。
別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。
よろしくお願いします。

Option Explicit

Sub データ分割転記()
　　Dim myPth As String, fname As String
　　Dim myRng As Range, myC As Range
　　Dim i As Long, x As Long
　　Dim wb(2) As Workbook
　　Dim ws As Worksheet
　　Dim t As Single

　　t = Timer
　　Set wb(0) = ThisWorkbook
　　myPth = wb(0).Path

　　With wb(0).Sheets("Key")
　　　　Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData
　　End With

　　For Each myC In myRng
　　　　Application.EnableEvents = False
　　　　Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm")
　　　　Set ws = wb(1).Sheets("List")

　　　　With wb(0).Sheets("DATA")
　　　　　　.Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value
　　　　　　.Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9")
　　　　　　.ShowAllData
　　　　End With
　　　　With ws
　　　　　　x = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myC.Offset(, 2).Value = x　'行数確認
　　　　　　.Range("A9").Value = 1
　　　　　　If x > 9 Then
　　　　　　　　.Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番
　　　　　　End If
　　　　End With

　　　　wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm"
　　　　wb(1).Close (False)
　　　　Application.EnableEvents = True
　　　　i = i + 1
　　Next
　　MsgBox i & "件を完了" _
　　& vbCrLf & Timer - t & " Sec."

End Sub

＊Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。

回答No.2

real beatin（@realbeatin） · ベストアンサー

こんにちは。お邪魔します。

題意への理解が至っているか自信はありませんが、
一応一通りのテスト環境を作って、
ご提示のSub、こちらが提示するSub、双方、
動作確認と簡単な検証は済ませています。

> いちいち新たに開き直さなくともよい方法はないでしょうか？

いちいち新たに開き直すことについて、どのような問題意識を持って質問に至るのか、
明示的に書いた方が回答が付け易いのかな？と感じました。
ご提示のSub、で、お求めに対して十分な結果が得られている？ということなのだとして、
「冗長な気がする」「もっとスッキリした記述が好ましい」「処理が遅い」
尺度によってトライは変わるかと思いますが、
それぞれの観点でにバランス良く改善が見られる方法、という難題としてお応えします。

> 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。

「閉じてしまい」というより、閉じるように命令している訳ですから、
直接的な回答としては、
>　　wb(1).Close (False)
を、ループの内側に書かないで済むように単純な設計を選ぶ、ということになるのではないでしょうか。

誤解が生まれないように少しだけ補足しますが、
wb(1)については、
>　　　　wb(1).SaveAs ...
を実行したとしても、wb(1)というWorkbookオブジェクトを捉え続けています。
言い換えると、
ＶＢＡからみれば、（VBProjectから他のProjectや他のクラス/ライブラリを参照しているという前提に帰れば）
.SaveAsの前後でwb(1)のブック名は変わりますが、
ひとつ（単一／同一）のブック（視覚的にも常に表示されるひとつのブック）
をオブジェクトとしてを捉えていることに
（wb(1)オブジェクトのインスタンスを解放（Set wb(1) = Nothing）するまでは、仮令wb(1)を閉じたとしても）
変わりはありません。
ですので、
.Copyメソッドで、wb(0).Sheets("DATA")の抽出データを、
貼り付けた（ws.Range("A9")以下の）セル範囲を、
.SaveAsの後で、元に戻してやれば、
>　　wb(1).Close (False)
ブックを閉じる必要はない、
ということが、今課題への直接的な解になるのだと考えています。
後は修正の範疇で、こちらが仮に設定した、
　　　　ws.Rows("9:" & x).Clear
を
（セル範囲を更に限定するとか、Deleteするとか、書式のコピーを追加するとか、
　予めSheets("List")の全セルのコピーをとって置いて、都度、貼り付け直す、とか）
実際の必要に合わせて工夫してみてください。

> 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。
Moveする前提で考えるなら、
元の雛型ブック"20150806TEST.xlsm"
を、テンプレートブック"20150806TEST.xltm"として保存しておけば、
　　With wb(0).Sheets
　　　　.Add Type:=myPth & "\20150806TEST.xltm", After:=.Item(.Count)
　　End With
　　wb(0).Sheets(indexarray).Move　'　indexarray は wb(0).Sheets.Count または 配列
　　Set ws = ActiveWorkbook.Sheets("List")
　　' ' 処理///抽出→転記→集計→付番
　　With ActiveWorkbook
　　　　.SaveAs _
　　　　　　Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm", _
　　　　　　FileFormat:=xlOpenXMLWorkbookMacroEnabled
　　　　.Close False
　　End With
のような流れで、一応可能は可能ですが、
この方法で改善点を見いだせる点があるとすれば、それはかなり特殊な事例です。
実際に書いて動かしましたが、より冗長で解り難く処理も遅くなります。

僭越ながら＃１補足コメントについて、

> それまでのファイルが残ってほしいのです。

「残ってほしい」のは何？という具体的な話があれば、
確信を持って応えることができる方は多数いらっしゃるかと、
元の雛型ブック、またはシート、（またはグラフ、テーブル、などなど）の
どのような属性（データ、書式、保護、ファイルフォーマット、などなど）を
踏襲させたいのか、によって、アプローチの仕方は多数あるように思います。

> いろいろしらべましたところ、SaveAs ではなくSaveCopyAsを使えばなんとかなりそうです。
先に元の雛型ブックをSaveCopyAsしてから、処理すれば、それはそれで出来るとは思いますが、
少し題意と逸れた気もしますし、言及するつもりはありません。

本題に帰って、
以下、提示するSubについてです。
概念的な理解を確かめておいて欲しいので、繰り返し強調しますが、
このSubプロシージャで扱うブックの数は、（Excel的にもVBA的にも）
処理全体を通じて、二つ、だけです。
結果的に作成/保存されるブックは、Keyの数、だけ複数です。
　　Dim wb(2) As Workbook
のような宣言を嗜好する向きには、整合性のとれた設計になっているとは思います。

必要最低限の書換えだけでお応えしますので、
エラー処理の追加、や、その他の最適化は書き加えません。
ご提示のSubでエラーになるケース、
（代表例で、Sheets("DATA")にフィルターが掛かっている場合の一部、など）
では、同じようにエラーがでます。
もし、こちらが提示したSubで、固有のエラーや誤作動が起こるとすれば、
　　　　ws.Rows("9:" & x).Clear
由来のものに（ほぼ）限定されます。

もし、何か不足はあれば、補足欄にでも書いてみてください。

' ' ///　動作確認環境は、Win7/xl2010/vba7

Sub Re9025307w()　'　データ分割転記
　　Dim myPth As String, fname As String
　　Dim myRng As Range, myC As Range
　　Dim i As Long, x As Long
　　Dim wb(2) As Workbook
　　Dim ws As Worksheet
　　Dim t As Single

　　t = Timer
　　Set wb(0) = ThisWorkbook
　　myPth = wb(0).Path

　　With wb(0).Sheets("Key")
　　　　Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData
　　End With

　　Application.EnableEvents = False
　　Application.ScreenUpdating = False

　　Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm")
　　Set ws = wb(1).Sheets("List")

　　For Each myC In myRng

　　　　With wb(0).Sheets("DATA")
　　　　　　.Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value
　　　　　　.Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9")
　　　　　　.ShowAllData
　　　　End With

　　　　With ws
　　　　　　x = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myC.Offset(, 2).Value = x　'行数確認
　　　　　　.Range("A9").Value = 1
　　　　　　If x > 9 Then
　　　　　　　　.Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番
　　　　　　End If
　　　　End With

　　　　wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm"

　　　　ws.Rows("9:" & x).Clear

　　　　i = i + 1
　　Next

　　wb(1).Close (False)

　　Application.EnableEvents = True
　　Application.ScreenUpdating = True

　　MsgBox i & "件を完了" & vbCrLf & Timer - t & " Sec."

End Sub

' ' //

お礼

realbeatin 様
http://okwave.jp/qa/q8939737.html
http://okwave.jp/qa/q8908989.html
では大変お世話になりました。

今回もありがとうございます！
> .Copyメソッドで、wb(0).Sheets("DATA")の抽出データを、
> 貼り付けた（ws.Range("A9")以下の）セル範囲を、
> .SaveAsの後で、元に戻してやれば、
>>　　wb(1).Close (False)
> ブックを閉じる必要はない、
> ということが、今課題への直接的な解になるのだと考えています。

言われてみれば、まったくその通りでした！
おかげさまで今回も無事解決いたしました。
またSaveCopyAs でも以下のように試してみました。
時間的にはこちらのほうが若干早いようです。

Sub データ分割転記New()
　　Dim myPth As String, fname As String
　　Dim myRng As Range, myC As Range
　　Dim i As Long, x As Long
　　Dim wb(2) As Workbook
　　Dim ws As Worksheet
　　Dim t As Single

　　t = Timer
　　Set wb(0) = ThisWorkbook
　　myPth = wb(0).Path
　　Application.ScreenUpdating = False
　　Application.EnableEvents = False
　　Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm")

　　With wb(0).Sheets("Key")
　　　　Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData
　　End With

　　For Each myC In myRng
　　　　Application.EnableEvents = False
　　　　Set ws = wb(1).Sheets("List")

　　　　ws.Range("A9:XFD" & Rows.Count).ClearContents

　　　　With wb(0).Sheets("DATA")
　　　　　　.Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value
　　　　　　.Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9")
　　　　　　.ShowAllData
　　　　End With

　　　　With ws
　　　　　　x = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myC.Offset(, 2).Value = x　'行数確認
　　　　　　.Range("A9").Value = 1
　　　　　　If x > 9 Then
　　　　　　　　.Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番
　　　　　　End If
　　　　End With

　　　　wb(1).SaveCopyAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm"

　　　　fname = Dir(myPth & "\作成ファイル\" & myC.Value & ".xlsm")

　　　　If fname <> "" Then '保存されたか念のため確認
　　　　　　myC.Offset(, 1).Value = "完了"
　　　　Else
　　　　　　myC.Offset(, 1).Value = "該当なし"
　　　　End If

　　　　i = i + 1
　　Next
　　wb(1).Close False
　　Application.EnableEvents = True
　　Application.ScreenUpdating = True
　　MsgBox i & "件を完了" _
　　& vbCrLf & Timer - t & " Sec."

End Sub

回答No.1

Prome_Lin

保存される前のどこかに「Application.DisplayAlerts = False」を入れられてはどうでしょうか？

この１行を入れると、確認メッセージが表示されません。

したがって、同じファイル名があった場合は、勝手に上書き保存されるので、その点は注意が必要ですが、ファイル名が順番に変わるようになっているので、大丈夫かと思います。

お礼

ありがとうございます。
ただ、
wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm"
wb(1).Close (False)
と、保存してから終了させているので、閉じる際のアラートはでません。
Application.DisplayAlerts = False　は不要です。

質問の書き方が良くなかったかもしれません。
名前をつけて保存をすると、新たにできたファイルが残り、それまでのファイルは保存されずに終了してしまいます。（手動でもそうなのですから当然ですが）
それまでのファイルが残ってほしいのです。
いろいろしらべましたところ、SaveAs ではなくSaveCopyAsを使えばなんとかなりそうです。