Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4483 / 76733

←次へ　｜　前へ→


	【77872】Re:オートフィルターの絞込列と抽出結果のコピペ列をずらしながらの繰り返し処理

β - 16/1/16(土) 8:58 -


	引用なし

	パスワード

▼綾香さん：

データが膨大なので、オートフィルター処理より、フィルターオプション処理のほうが
早いかもしれません。

Sub Test2()
　　Dim shD As Worksheet
　　Dim shF As Worksheet
　　Dim r As Range
　　Dim dest As Long
　　Dim flg As Long
　　Dim sls As Long
　　
　　
　　Application.ScreenUpdating = False
　　
　　Set shD = Sheets("Data")
　　Set shF = Sheets("Filter")
　　
　　shF.UsedRange.ClearContents
　　
　　Set r = shD.UsedRange.Columns("A:RE")
　　shD.Range("RG2").Value = "ON"　　　　　　　　　　　　　　　 '検索条件
　　
　　dest = Columns("A").Column
　　sls = Columns("FL").Column
　　
　　For flg = Columns("NH").Column To Columns("RE").Column
　　　　shD.Range("RG1").Value = shD.Cells(1, flg).Value　　　　'検索項目
　　　　shF.Cells(1, dest).Resize(, 3).Value = Array(shD.Range("D1").Value, shD.Range("G1").Value, shD.Range("J1").Value)
　　　　shF.Cells(1, dest + 3).Value = shD.Cells(1, sls).Value
　　　　r.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　CriteriaRange:=shD.Range("RG1:RG2"), CopyToRange:=shF.Cells(1, dest).Resize(, 4), Unique:=False
　　　　　　
　　　　dest = dest + 5
　　　　sls = sls + 1
　　　　
　　Next
　　
　　shD.Range("RG1:RG2").Clear
　　shF.Select
　　
End Sub

3 hits

▼

【77868】オートフィルターの絞込列と抽出結果のコピペ列をずらしながらの繰り返し処... 綾香 16/1/16(土) 0:26