Ｅｘｃｅｌ ＶＢＡでのオートフィルタについて

質問

Ａ　　　Ｂ　　　Ｃ　　Ｄ
１国語　３点　２組　鈴木
２国語　３点　２組　佐藤
３算数　２点　２組　前田
４算数　２点　２組　上松
５算数　２点　３組　高橋

というデータをＡ列の教科ごとにデータを抽出し、別シートに貼り付けるマクロを考えていますがどのようにすれば良いでしょうか？（この場合、A1:D2をSheet1へ。A3:D5をSheet2へ。）IF thenやDO loopを組み合わせればよいのかも知れませんが上手くいきません。宜しくお願いします。

回答No.8

Wendy02

こんばんは。

＞シートにはフィールド名を表示させないようにするにはどうすればよいでしょうか？

一番簡単なのは、

行を隠す方法:

●　Worksheets("Sheet1")の部分は、適宜合うようにしてください。

　Worksheets("Sheet1").Rows(1).Hidden = True '隠す
　'Worksheets("Sheet1").Rows(1).Hidden = False '隠れたものを出す

このようなコードを最後に加えてあげることですね。

＞貼り付ける先はA5からしたへ向かって貼り付けるにはどうすればよいでしょうか？

Sub SortPickup2()マクロの真中あたり。

　'キーは、1列目に設定
　　 .AutoFilter Field:=1, Criteria1:=d.Value
　　 .Copy
　　　With Worksheets.Add(After:=Worksheets(Sheets.Count))
　　　　　 .Range("A5").PasteSpecial Paste:=xlValues 'Range("A1") からRange("A5") に

なお、書式シートは、そのままで、書式のほうだけをA5 ～にあわせればよいと思います。

それから、こちらで試している最中に、元データシートを開かないままに、開いたばかりのデータにマクロを掛けると、抽出する際に、「フィールド名がないから抽出出来ない」というようなメッセージが出ました。マクロにより、シートを選択しActiveにしているはずです。原因は、私のデータは、フィールド名とデータ部分との境目がはっきりしていないせいかもしれませんが、シートに、実際のセルポインターおいてから行ったら、エラーは出ませんでした。

もし、このようなエラーが頻繁に繰り返すようでしたら、オプションを取り付けます。

補足

返答が遅くなり申し訳ございません。貴殿のマクロですと、データの容量が大きくなると固まるようです。
回避方法をご教授いただけるようお願い申し上げます。

回答No.7

KenKen_SP

こんにちは。

【 #4 補足欄に書いて頂いた件について】

q=1227504 の #9 のコードの目的はユーザーがシート仕訳の際にキーとな
る列を任意指定できるようにすることで、コードの修正を必要としない汎
用的に使えるものとすることにあります。

余計なことであったのかもしれませんが、本スレッドの #4 の意図はここ
にあります。ですから、「ご参考までに」と、

組別とか氏名別でもシートを分けることがあるのかもしれない、、、

そう考えて投稿しました。

したがって、キー列を固定化するのであれば、Wendy02 さんのコードが
ご希望通り動作しますし、何より高速で良いのではないでしょうか？

【 #4 お礼欄に書いて頂いた件について】

> あらかじめ書式や罫線を設定したシートに複写するのにはどうすれば
> よいのでしょうか？

ご質問文を拝見する限り、データ件数が不定みたいなのですが、もしそう
であれば、テンプレートシートを使うメリットは薄れます。

例えば、テンプレートで罫線を100行まで引いてあったとしても、抽出
データが150件だったら、結局テンプレートからはみ出した分について罫線
などの書式を手作業で設定し直すわけですよね？

VBA で罫線やセル書式を整える方法の方が良いのではないでしょうか。

回答No.6

Wendy02

こんにちは。

>こちらのマクロでは作動しませんでした。

私のコードの場合は、最初からワークシート名が決められていて、その環境に合わせて、ユーザー設定更してもらわないと、動かないと思います。

この件は、今のところ、自分のコードは、ご要望に合ったものとして、こちら側で、一応、動作チェックは済んで公開させていただきました。ですから、こちらのコードの内容に及ばない限りは、このままにさせていただきます。
失礼いたします。

お礼

シート名をsheet1変更したところ作動しました。ありとうございました。ところで、貼り付けられたシートにはフィールド名を表示させないようにするにはどうすればよいでしょうか？また、貼り付ける先はA5からしたへ向かって貼り付けるにはどうすればよいでしょうか？

回答No.5

Wendy02

こんばんは。

#3 の私の書いた内容に問題や不都合があったのでしたら、そのままにしてください。このマクロは、ブックにシートを追加してしまうコードですから、もし一つのマクロに決めたら、負担になりますから、問題がなければ、あえて他のものを試す必要はありません。ただ、私も、一応手をつけた以上、自分なりに完結させておきます。

(1)　A1:I1の固定
(2)　キーをＡ列に固定
(3)　書式や罫線を設定したシートに複写
(ただし、あらかじめ書式や罫線を設定したシート－以下では、「書式シート」を用意します。そのシートに書式を入れておきます。その書式をコピーします。）

'-----------------------------------------------------------
'<標準モジュール>
Option Explicit
Sub SortPickup2()
　Dim Rng As Range, myData As Range, d As Range
　Dim MotoSheet As Worksheet
　　'元のデータのシート
　　Set MotoSheet = Worksheets("Sheet1")
　　MotoSheet.Select
　　'基礎データを取る
　　Set Rng = MotoSheet.Range("A1:I11") '(1)データの範囲
　　'データのない時のエラー処理
　　If Rng.Count = 1 Then MsgBox "データがありません。", 16: Exit Sub
　　Application.ScreenUpdating = False
　　With Rng
　　　'ユニークデータの取得
　　　.Columns(1).AdvancedFilter _
　　　　Action:=xlFilterCopy, _
　　　　CopyToRange:=Range("IV1"), _
　　　　Unique:=True
　　　Set myData = Range("IV2", Range("IV2").End(xlDown))
　　　'オートフィルター
　　　On Error Resume Next
　　　For Each d In myData
　　　 '(2) キーは、1列目に設定
　　　　.AutoFilter Field:=1, Criteria1:=d.Value
　　　　.Copy
　　　　 With Worksheets.Add(After:=Worksheets(Sheets.Count))
　　　　　　　 .Range("A1").PasteSpecial Paste:=xlValues
　　　　'(3)　書式コピー
　　　　 Worksheets("書式シート").UsedRange.Copy
　　　　　　　.Range("A1").PasteSpecial xlPasteFormats
　　　　　　　.Range("A1").Select
　　　　 End With
　　　Next
　　　On Error GoTo 0
　　End With
　　'終了処理
　　If Not MotoSheet.AutoFilter Is Nothing Then
　　　Rng.AutoFilter
　　End If
　　myData.EntireColumn.ClearContents 'ユニークデータの削除
　　Application.ScreenUpdating = True
　Set Rng = Nothing: Set myData = Nothing
　MotoSheet.Activate
　Set MotoSheet = Nothing
　Beep '終了合図
End Sub
'-----------------------------------------------------------

お礼

ありがとうございます。
ただ、申し訳ありませんがこちらのマクロでは作動しませんでした。

回答No.4

KenKen_SP

こんにちは。

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1227504

で同様の内容につき、#9で回答しています。

シートに仕訳するキーとなる列を指定できたりしますので、
例えば、組別とか氏名別でもシートを分けることができます。

しかし、アホかと思うほど長く読みにくいコードです。

ご参考までに。

参考URL：

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1227504

お礼

本当にこのマクロには感動です。
追加の質問で恐縮なのですが、あらかじめ書式や罫線を設定したシートに複写するのにはどうすればよいのでしょうか？書式や罫線を設定した空のシートにデータのみ追加したいのです。当然のことながら、その書式や罫線を追加したシートはシートの数だけ複写されるものです。

補足

>Set rngMidasi = Application.InputBox( _
　　　　Prompt:="データ見出しの 「セル範囲」 を選>択して下さい", Type:=8)
　　If rngMidasi Is Nothing Then GoTo ExitHandler

この部分をA1:I1の固定にするにはどのように記述すればよいでしょうか？

>Set rngKeyCol = Application.InputBox( _
　　　　Prompt:="データ範囲を選択しました。" & >vbCrLf & vbCrLf & _
　　　　　　　　"次に、シート仕訳のキーとなる列全>体を選択して下さい", Type:=8)
　　If rngKeyCol Is Nothing Then GoTo ExitHandler

この列をＡ列に固定したい場合はどのようにすればよいでしょうか？

初心者故、引用が適切でないかもしれませんがご笑納ください。

回答No.3

Wendy02

こんばんは。

最初のサンプルを見る限りは、フィールド名がありません。

Ａ　　　Ｂ　　　Ｃ　　Ｄ
１教科　点数　　組　名前

上記のように、フィールド名がなくてはなりません。

こういうデータには、必須の基本なので、それがあるという前提で進めさせていただきます。そうしないと、コードが倍以上の長さになるかもしれません。

現在のコードは、シート１に元のデータがあり、同じブックにコピーする方法になっています。もし、違うブックにする場合は、

プロシージャの中の　Worksheetsの前にブック名を入れ、シートインデックスを適当に替えてください。なお、シートインデックスは、シートの順という意味です。

'シートインデックスによる、シートへのコピー
.Copy WorkBook("A.xls").Worksheets(ShIndex).Range("A1")
として、
　ShIndex = 2 'シートのインデックスの始まり
の部分を適当に直してください。(始まりの数字)

＞オートフィルタで選んで新しいシートへ貼り付ける作業を自動化したいのです。

という要件には合っているはずです。ユニークなデータを取るところがうまくいかないのではないかと思いました。

'<標準モジュールのみ>
Option Explicit
Sub SortPickup()
　Dim Rng As Range, myData As Range, d As Range
　Dim ShIndex As Integer
　'
　ShIndex = 2 'シートのインデックスの始まり

　　'基礎データを取る
　　Set Rng = Range("A1").CurrentRegion
　　'データのない時のエラー処理
　　If Rng.Count = 1 Then MsgBox "データがありません。", 64: Exit Sub
　　Application.ScreenUpdating = False
　　With Rng
　　　'ユニークデータの取得
　　　.Columns(1).AdvancedFilter _
　　　Action:=xlFilterCopy, _
　　　CopyToRange:=Range("IV1"), _
　　　Unique:=True
　　　Set myData = Range("IV2", Range("IV2").End(xlDown))
　　　'オートフィルター
　　　For Each d In myData
　　　　.AutoFilter Field:=1, Criteria1:=d.Value
　　　　If Worksheets.Count < ShIndex Then
　　　　　Worksheets.Add After:=Worksheets(Worksheets.Count)
　　　　End If
　　　　'シートインデックスによる、シートへのコピー
　　　　.Copy Worksheets(ShIndex).Range("A1")
　　　　ShIndex = ShIndex + 1
　　　Next
　　End With
　　'終了処理
　　If Not ActiveSheet.AutoFilter Is Nothing Then
　　　Rng.AutoFilter
　　End If
　　ActiveSheet.Columns(256).ClearContents 'ユニークデータの削除
　　Application.ScreenUpdating = True
　Set Rng = Nothing:　Set myData = Nothing
　Beep '終了合図
End Sub

回答No.2

imogasi

例データ　Sheet1
科目でソートする。
国語　 ３点　 ２組　 鈴木
国語　 ３点　 ２組　 佐藤
算数　 ２点　 ２組　 前田
算数　 ２点　 ２組　 上松
算数　 ２点　 ３組　 高橋
理科 ４点 ２組　 木下
Sheet1は一番左にシートタブをもって行っておくこと。
Sub test02()
d = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
m = Worksheets("Sheet1").Cells(1, "A")
s = 2
j = 1
For i = 1 To d
If Worksheets("sheet1").Cells(i, "A") = m Then
Worksheets(s).Cells(j, "A") = Worksheets("Sheet1").Cells(i, "A")
Worksheets(s).Cells(j, "B") = Worksheets("Sheet1").Cells(i, "B")
j = j + 1
Else
s = s + 1
j = 1
Worksheets(s).Cells(j, "A") = Worksheets("Sheet1").Cells(i, "A")
Worksheets(s).Cells(j, "B") = Worksheets("Sheet1").Cells(i, "B")
j = j + 1
m = Worksheets("Sheet1").Cells(i, "A")
End If
Next i
End Sub
結果
Sheet2
国語　 ３点 C列以下省略
国語　 ３点　
Sheet3
算数　 ２点　
算数　 ２点　
算数　 ２点　

以下略
もし科目名をシートに入れているなら、A列科目の出現順序とシートの左からの順序をあわせてください。

回答No.1

hana-hana3

オートフィルタを使う場合、コピー範囲は「全データ領域」で構いません。
実際に貼り付けられるのは、フィルタで抽出されたデータのみになりますからね。

難しく考える必要はありませんよ。

教科名でフィルタをかける
Range("A1:D5").copy
任意のシートへ貼り付け
　　：
繰り返し

となります。

教科名と貼り付け先を配列に入れてしまえば、Ｆｏｒ文で等で繰り返し処理できます。

補足

早速のレスありがとうございます。

>教科名でフィルタをかける
実際のデータには教科名は30種類以上あり、その都度オートフィルタが煩雑なのでマクロを選んだのですが・・ボタンを押すと、その都度シートへデータが貼り付けられ、次にボタンを押すとまた新しいデータが貼り付けられるような・・・オートフィルタで選んで新しいシートへ貼り付ける作業を自動化したいのです。それには例えも悪かったですし言葉も足りませんでした。すいません。

>教科名と貼り付け先を配列に入れてしまえば、Ｆｏｒ文で等で繰り返し処理できます。
具体的にはどのような構文になるのでしょうか？実は、それが知りたいのです。お願いします。