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

解決済みの質問

エクセル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が持つイベントマクロを作動させないためです。

投稿日時 - 2015-08-06 11:48:22

QNo.9025307

すぐに回答ほしいです

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

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

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

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

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

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

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

誤解が生まれないように少しだけ補足しますが、
wb(1)については、
>    wb(1).SaveAs ...
を実行したとしても、wb(1)というWorkbookオブジェクトを捉え続けています。
言い換えると、
VBAからみれば、(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
のような流れで、一応可能は可能ですが、
この方法で改善点を見いだせる点があるとすれば、それはかなり特殊な事例です。
実際に書いて動かしましたが、より冗長で解り難く処理も遅くなります。

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

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

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

> いろいろしらべましたところ、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

' ' //

投稿日時 - 2015-08-07 21:01:21

お礼

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

投稿日時 - 2015-08-08 11:42:18

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

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

回答(2)

ANo.1

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

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

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

投稿日時 - 2015-08-06 21:13:25

お礼

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

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

投稿日時 - 2015-08-07 00:53:52

あなたにオススメの質問