[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フィルタ抽出後データを別Bookに繰り返し貼り付け』（たつろー）
本件でご質問させていただきます。
下記のコードを実行しているのですが、
オートメーションがタイムアウト（xlBook.Closeのところ？）してしまうか、?@?Aのどちらのファイルもドキュメントの回復という現象になってしまいます。解決策が見つかっておらず、ご相談させてください。
【仕様】
?@データを持つExcelファイルからマスターシートの組織をもとに、データシートの組織にフィルタを順次ループ処理をさせる
Sheet1：データ（2行目がタイトル行）
Sheet2：マスター（組織名称）
?A下記テンプレートファイルに抽出後のデータを値貼り付けする
D:\Tempalate.xlsx（読み取り専用）
?@ファイルのマクロ（ループ処理は除いています）
Sub sample()
'Excelのオブジェクト生成
Set xlApp = CreateObject("excel.application")
'データを転記するテンプレート
Filename = "D:\Tempalate.xlsx"
'Excelを開く
Set xlBook = xlApp.Workbooks.Open(Filename)
'シート指定
Set xlSheet = xlBook.Worksheets("Sheet1")
'データ領域に対してフィルタをかける
Worksheets("Sheet1").Range("A2").AutoFilter Field:=1, Criteria1:=2
'データ領域の抽出データをコピー
Worksheets("Sheet1").Range("A2").CurrentRegion.Copy
'タイトル行を含めて値貼り付け
xlSheet.Range("A2").PasteSpecial xlPasteValues
'名前を付けて保存
xlBook.SaveAs "P:\Tempalate_2.xlsx"
'Bookを閉じる
xlBook.Close
'Excel Appを終了
xlApp.Quit
MsgBox "完了"
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
明示的にThisworkbook.の修飾を付けても付けなくても
症状は変わりません。
（たつろー） 2019/10/03(木) 13:42
既存ファイルの上書きを強制するため、DisplayAlertsだけは残し、
それ以外の処理をスキップしたところ、うまく動作するようになりました。
With xlApp
.ScreenUpdating = False/True
.Calculation = False/True
.DisplayAlerts = False/True
End With
（たつろー） 2019/10/03(木) 13:56
'Excelのオブジェクト生成
Set xlApp = CreateObject("excel.application")
■２
＞明示的にThisworkbook.の修飾を付けても付けなくても
＞症状は変わりません。
と仰っているので、事象の解決に繋がらないのかもしれませんが、見やすさの観点から考えても、操作しているつもりのオブジェクトがどのブックのものなのか、明示する工夫をしたほうが良いような気がします。
■３
提示のコードを、私なりに整理すると↓みたいになりました。なんかの参考になれば。
（といいつつ実データでチェックしてないのでミスってるかもです）
Sub さんぷる()
Dim dstWB As Workbook
'▼自ブックのSheet1シートでオートフィルタの操作
With ThisWorkbook.Worksheets("Sheet1")
.AutoFilterMode = False 'オートフィルタ強制解除
'----ループさせるなら▼ここから▼---------
.Range("A2").AutoFilter Field:=1, Criteria1:=2 'A2セルを含む表範囲にオートフィルタを設定して1列目の「2」を抽出
Set dstWB = Workbooks.Open("D:\Tempalate.xlsx") '転記先のブックを開く
.AutoFilter.Range.Copy dstWB.Worksheets("Sheet1").Range("A2") '抽出されているものを、転記先ブックのSheet1シートのA2以降に貼付
dstWB.SaveAs "P:\Tempalate_2.xlsx" '転記先ブックを別名で保存
dstWB.Close '転記先ブックを閉じる
'----ループさせるなら▲ここまで▲---------
End With
If MsgBox("完了しました" & vbCrLf & "このブックを閉じますか？", vbYesNo) = vbYes Then
If Workbooks.Count = 1 Then
Application.Quit
Else
ThisWorkbook.Close
End If
End If
End Sub
（もこな２ ） 2019/10/03(木) 14:02
１．いかにも処理している（画面がちらつく）というのが嫌いです。
今回、十数万件のレコード、分割ファイル数は数百にもなりますので、バックグラウンドで処理させたいと思いました。大した理由はないです。
２．おっしゃる通り、可読性という意味では有効かもしれません。
３．サンプルありがとうございます。
こんな方法もあったのですね。勉強になります。
４．パフォーマンスが悪いので、改善を試みています。
もう1点、ご相談よろしくお願いいたします。
1.フィルタ抽出後のデータを配列に取得し、Rangeオブジェクトに格納
2.RangeオブジェクトからVariant型の配列に格納
3.別ブックに配列のままデータ領域のみを転記
できるにはできたのですが、4-１のところの書き方がいまいちです。
一気にRangeオブジェクトに格納する書き方がないでしょうか？
With ThisWorkbook.Worksheets("Sheet1")
'データ領域に対してフィルタをかける
.Range("A2").AutoFilter Field:=1, Criteria1:=2
'抽出データをRangeオブジェクトに格納
Set myRange = .Range("A2").CurrentRegion
'交差領域をRangeオブジェクトに格納
Set myRange = Application.Intersect(myRange, myRange.Range("A3", "G" & .UsedRange.Rows.Count))
'可視セルのみを取得
Set myRange = myRange.SpecialCells(xlCellTypeVisible)
End With
（たつろー） 2019/10/03(木) 21:29
■５
＞ 1.フィルタ抽出後のデータを配列に取得し、Rangeオブジェクトに格納 ＞ 2.RangeオブジェクトからVariant型の配列に格納 ＞ 3.別ブックに配列のままデータ領域のみを転記
そもそも、オートフィルタで抽出した範囲を【コピー】する場合、デフォルトで可視セルしかコピー対象になりません。（Excel2002〜らしいです）
http://officetanaka.net/excel/vba/tips/tips155c.htm
なので、配列に入れなくても
1.抽出する 2.コピーする 3.出力先へ値貼り付けする
でよくないですか？
（書式もコピーしてよいなら、既に示したとおり、Copyメソッドの引数に貼付先を指定すれば1行で済みます。）
（もこな２） 2019/10/03(木) 22:28
そうすると私の最初の疑問がまた浮上します。
ScreenUpdatingを止めると、私の最初に提示したコードは全く機能しませんでした。
この点についてはどのようにお考えでしょうか？
ご提示していただいたコードはとても良いものだと思っています。
ただ、数十万レコードありますのでよりパフォーマンスの良い方法がないかと模索しています。
ご質問そのものを否定されてしまうと、ご相談した意味がなくなってしまいます。
どちらがパフォーマンスが良いかは、実際に検証をして判断したいと思っています。
（たつろー） 2019/10/03(木) 23:40
横から失礼します
＞オートメーションがタイムアウト（xlBook.Closeのところ？）してしまうか、?@?Aのどちらのファイルもドキュメントの回復という現象になってしまいます。
原因がわかりました。(と思います）
＞ 'データ領域の抽出データをコピー
＞ Worksheets("Sheet1").Range("A2").CurrentRegion.Copy
＞ 'タイトル行を含めて値貼り付け
＞ xlSheet.Range("A2").PasteSpecial xlPasteValues
ここなんですけど、別プロセスのセルをコピーして、貼り付けているということを 理解されているしょうか？
手作業で実験しましたが、コピー元が数式セルの場合、 別プロセスのシートに貼り付けようとすると、アラートがでて 「別プロセスからの・・・・値のみで貼り付けられます」で 確認待ちになります
OKをクリックすると、値で貼り付けられます
質問者さんの場合 xlApp.Visible = True にしていないので 裏で、アラートが出たまま 固まっていたのではないかと思います。
それを
Application.DisplayAlerts = False
にすることで、回避してうまくいったということでしょう。
本来、別プロセスのアプリからの貼り付けでは xlPasteValues は使わない（使えない？） のではないでしょうか？
ということで、まずは 別プロセスのExcelを立ち上げることは疑問です。
次に パフォーマンスについて 参考出品です
大量のデータを作っている暇もないので
可能であればそちらのデータで検証してもらえればと思います オートフィルターではなく フィルタオプション を使っています
Sub test1()
Dim myFrmRng As Range
Dim myCrng As Range
Dim myToRng As Range
Dim myCAr As Variant
Dim i As Long
myCAr = Array("東京", "神奈川", "千葉") '抽出条件配列
With Worksheets("Sheet1")
Set myFrmRng = .Range("A1").CurrentRegion '元データ範囲
Set myCrng = .Range("H1:H2") '条件範囲
Set myToRng = .Range("J1:O1") '抽出先見出し
End With
Application.ScreenUpdating = False
For i = LBound(myCAr) To UBound(myCAr)
myCrng.Cells(2).Value = myCAr(i) '抽出条件セット
myFrmRng.AdvancedFilter _
Action:=xlFilterCopy _
, CriteriaRange:=myCrng _
, CopyToRange:=myToRng _
, Unique:=False 'フィルタオプション
With Workbooks.Add '新規ブックを追加し、貼り付け後保存
myToRng.CurrentRegion.Copy .Worksheets(1).Range("A1")
.SaveAs ThisWorkbook.Path & "\" & myCAr(i) & ".xlsx", xlOpenXMLWorkbook
.Close
End With
Next
Application.ScreenUpdating = True
End Sub
参考まで
（渡辺ひかる） 2019/10/04(金) 11:02
コピー元は全て値ではありました。
本来、別プロセスのアプリからの貼り付けでは xlPasteValues は使わない（使えない？） のではないでしょうか？
この点、勉強になりました。注意いたします。
オートフィルタを使いましたが、別シートに値で貼って、更に、別ファイルに値で貼り付けというロジックは、まず最初に試していました。これをフィルタオプションを使ってやっているのですね。こちらのパフォーマンスは良いですね。たいへん勉強になりました。
（たつろー） 2019/10/04(金) 14:07
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.