Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
864 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【77868】オートフィルターの絞込列と抽出結果のコピペ列をずらしながらの繰り返し処... 綾香 16/1/16(土) 0:26 質問[未読]
【77870】Re:オートフィルターの絞込列と抽出結果の... β 16/1/16(土) 8:35 発言[未読]
【77872】Re:オートフィルターの絞込列と抽出結果の... β 16/1/16(土) 8:58 発言[未読]
【77876】Re:オートフィルターの絞込列と抽出結果の... 綾香 16/1/16(土) 17:17 お礼[未読]
【77868】オートフィルターの絞込列と抽出結果のコ...
質問  綾香  - 16/1/16(土) 0:26 -
引用なし
パスワード
   いつもお世話になっております。

Excelでオートフィルターの絞込列をずらしながら、
絞り込んだデータを別シートにコピペしたいのですが
どのようなVBAにすればいいか教えていただきたく投稿いたします。
お手数をおかけして恐縮ではございますが、お力をお貸しいただけますと幸いです。

やりたいことは以下の通りです。
------------------------------------------------------------------------------

「Data」というシートのA列〜FK列に商品情報が、FL列〜JI列に各月の販売データが、
NH列〜RE列に販売データをもとに設定した”ON/OFF”情報が入力されています。
(例えばFL列のデータとNH列のFLGが対応)

この「Data」シートでオートフィルタ―を使い、
　1. NH列をON”で絞り込む操作をした後、
　2. D/G/J列(この3列は固定)とFLGに対応する販売データ(FL列)をコピーして
　3. 同ファイル内にある「Filter」シートのA1セルに張り付け、
　4.「Data」シートのフィルタを解除する
という処理を1まとまりとして、これをFLG列分繰り返したく思います。
（NH列の次はNI列でフィルタをかけ、D/G/J列とFM列をコピーして、
　「Filter」シートのG1セルに張り付け）

単純にフィルタをかけるVBAは下記で対応できたのですが、
絞込列とコピペ列をずらして繰り返し処理するにはどうしたらいいでしょうか。

Sub Sample()
　　With Sheets("Data").Range("NH1")
　　　　.AutoFilter Field:=1, Criteria1:="ON"
　　End With
End Sub


お手数をおかけして恐縮ではございますが、
重ねてお力添えのほど宜しくお願い致します。


【やりたいことのまとめ】
　・絞込条件列を1列ずつずらしてフィルタをかける
　・コピー列を1列ずつずらしてコピーする(ただし、D/G/J列は常にコピー対象)
　・貼付け済みのデータから1列空けた列に貼付けを行う
【77870】Re:オートフィルターの絞込列と抽出結果...
発言  β  - 16/1/16(土) 8:35 -
引用なし
パスワード
   ▼綾香 さん：

データが膨大なので、テストデータをつくるのもおっくうで、検証していません。
書きなぐっただけです。膨大な表なので、それなりに処理時間はかかると思います。

Sub Test()
　　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
　　shD.AutoFilterMode = False
　　
　　shD.UsedRange.Columns("A:RE").AutoFilter
　　Set r = shD.AutoFilter.Range
　　
　　dest = Columns("A").Column
　　sls = Columns("FL").Column
　　
　　For flg = Columns("NH").Column To Columns("RE").Column
　　
　　　　r.AutoFilter field:=flg, Criteria1:="ON"
　　　　If r.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
　　　　　　r.Columns("D").Copy shF.Cells(1, dest)
　　　　　　r.Columns("G").Copy shF.Cells(1, dest + 1)
　　　　　　r.Columns("J").Copy shF.Cells(1, dest + 2)
　　　　　　r.Columns(sls).Copy shF.Cells(1, dest + 3)
　　　　End If
　　　　
　　　　shD.ShowAllData
　　　　dest = dest + 5
　　　　sls = sls + 1
　　　　
　　Next
　　
　　shD.AutoFilterMode = False
　　shF.Select
　　
End Sub
【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
【77876】Re:オートフィルターの絞込列と抽出結果...
お礼  綾香  - 16/1/16(土) 17:17 -
引用なし
パスワード
   β様

早々にご教授いただきありがとうございます！

オートフィルタで無事に処理することができました。
処理時間も気になるほどではなく、大変助かりました。
いただいたフィルタオプション処理についても勉強してみます！

取り急ぎ御礼まで。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
864 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free