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