VBA？を使って フィルタ別セルで表示

質問

現在下記のようなエクセルがあります。
ID　職種　氏名　出勤回数
1　　A　　田中　　　50
2　　B　　佐藤　　　25
3　　C　　上田　　　10
4　　A　　木村　　　15
5　　B　　多田　　　20

これを　同じシート内の別の所に　職種別に出勤回数の昇降順に一覧で出したいです。↓
職種　ID　　氏名　　出勤回数
A　　　1　　田中　　　50
A　　　4　　木村　　　15

色々調べて何処からか取ってきましたが
Sub AdvancedFilter_1()
Dim Drange As Range, Crange As Range
Worksheets("Sheet1").Select
' 検索条件式の入力
Range("H1").Value = Range("B1").Value
Range("H2").Value = "A"
' フィルタの実行
With Worksheets("Sheet1")
Set Drange = .Range("A1").CurrentRegion
Set Crange = .Range("H1").CurrentRegion
End With
Range("A1").Select
Drange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Crange, Unique:=False
Set Drange = Nothing
Set Crange = Nothing
End Sub

上記のような形で入力したため　昇降順にならず
又、表示場所も　元のデータの所になってしまいます。

どなたかうまくいくコードを教えていただけないでしょうか？
尚、最終的には　ボタンを作成し　データが入れ替わる度に計算しなおせる様にしたいと思っています。

回答No.9

xls88

Excelのバージョンは？
下記で試してください。

Sub test2()
Dim Drange As Range, Crange As Range
Dim Prange As Range
Dim Srange As Range
Dim MyAry As Variant
Dim i As Long, j As Long

MyAry = Array("A", "B", "C")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
.Range("H1").Value = .Range("B1").Value
For i = 0 To UBound(MyAry)
.Range("H2").Value = MyAry(i)
Set Drange = .Range("A1").CurrentRegion
Set Crange = .Range("H1").CurrentRegion
With Worksheets("Sheet1")
Set Prange = .Cells(11, i + j + 1)
Drange.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Crange, _
CopyToRange:=Prange, _
Unique:=False

Set Srange = .Range(Prange, Prange.End(xlDown)).Resize(, 4)

'行単位並べ替え
Srange.Sort Key1:=Srange(, 4), _
Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal

'列単位並べ替え
Srange.Resize(, 2).Sort Key1:=Srange(, 1), _
Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlLeftToRight, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End With
j = j + 3
Next i
End With
Application.ScreenUpdating = True
End Sub

回答No.8

xls88

＞回答番号：No.7 この回答への補足

＞.Sort.SortFields.Clear
＞の所でエラーが出ます。
ということなら、エラー番号とか内容も合わせて報告するのがベストです。
こちらではエラーにならないので検討の仕様がありません。

補足

段取りが悪くすいません。
エラーは実行時エラー’438’
オブジェクトはこのプロパティまたはメソッドをサポートしていません。

と出ます。しかしエラーにはなっても
SHEET2に職種Aのみは表示されています。ただ　出勤回数順には並んでいません。

回答No.7

xls88

進展が感じられませんが、どうされていますか？
解決できたのですか？
まだ未解決なら投げ出すのが早過ぎやしませんか。

別シートに書き出すようにしてみました。

Sub test1()
Dim Drange As Range, Crange As Range
Dim Prange As Range
Dim Srange As Range, Krange As Range
Dim myAry As Variant
Dim i As Long, j As Long

myAry = Array("A", "B", "C")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
.Range("H1").Value = .Range("B1").Value
For i = 0 To UBound(myAry)
.Range("H2").Value = myAry(i)
Set Drange = .Range("A1").CurrentRegion
Set Crange = .Range("H1").CurrentRegion
With Worksheets("Sheet2")
Set Prange = .Cells(1, i + j + 1)
Drange.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Crange, _
CopyToRange:=Prange, _
Unique:=False

Set Srange = Range(Prange, Prange.End(xlDown)).Resize(, 4)
Set Krange = Srange(, 4).Offset(1).Resize(Srange.Rows.Count - 1)

.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Krange, SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
With .Sort
.SetRange Srange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Srange.Resize(1), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
With .Sort
.SetRange Srange.Resize(, 2)
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
End With
j = j + 3
Next i
End With
Application.ScreenUpdating = True
End Sub

補足

すいません。諦めていませんが進展はないです。・・

上記コードを試してみまし。ありがとうございます。
しかし
.Sort.SortFields.Clear
の所でエラーが出ます。
これは会社のパソコンがエクセル2000だからでしょうか？
もしくは　この前にActiveWorkbook.Worksheets("Sheet1")
が入りますか？

ちなみに上記(ActiveWorkbook.Worksheets("Sheet1"))を入れると
色んな所がエラーになりパニックになってしまいました・・・

回答No.6

rukuku

＞又、このデータは非常に大増量となりますので
＞Aの表示列、Bの表示列　と列を分けたいと考えています。

もう少し具体的な状況を教えてください。
質問の文面からは「列は元々分かれている」と理解します。

補足

質問が分かりにくく申し訳ありません。
かなり　希望の形に近づいてきました。
＞Aの表示列、Bの表示列　と列を分けたいと考えています。
まずこのエクセルシートはIDと氏名と職種　毎日の出勤時間が365日分入っています。最後の列には　年間出勤回数が自動計算されるシートになっています。
希望は　職種別に　ID　氏名　年間出勤回数が多い順に一発で分かるようにさせたいということです。
上記のVBAだと以下のようになってしまいます・・
職種　ID　　氏名　　出勤回数　　
A　　　1　　田中　　　50
A　　　4　　木村　　　15
B　　　5　　多田　　　50
B　　　2　　佐藤　　　25
これでは　列が長くなってしまい見にくくなってしまいます。
出来れば職種ごとに列分けしたいと思います。
職種　ID　　氏名　　出勤回数　　職種　ID　　氏名　　出勤回数
A　　　1　　田中　　　50　　　　B　　　5　　多田　　　50
A　　　4　　木村　　　15　　　　B　　　2　　佐藤　　　25

ちなみに　別シートで見れる・・という形の方が本当は見やすいと思います。別シートに作成の方が簡単なのでしょうか？

回答No.5

rukuku

＞A：C,Hという感じなのですがうまくいきません。

Excell2000でテストしてみた結果。
Range("A:C,H:H").Select
ではうまくいきました。
Columnsではエラーになってしまいました。

回答No.4

rukuku

まず、
＞昇降順にならず
これは「AdvancedFilter」にそのような設定はないためです。
「AdvancedFilter」は、条件に合うデータだけを抜き出すことが出来ますが、並べ替えるという機能は持っていません。

＞表示場所も　元のデータの所になってしまいます。
これは
Action:=xlFilterInPlace
の設定のせいです。この設定は「元のデータを置き換える」です。他のセルにコピーを取るには「xlFilterCopy」とする必要があります。
またコピー先は、「CopyToRange」で設定します。

出来るだけのサポートはしたいと思います。私の説明で分からないことがあったら遠慮なく質問してださい。

回答No.3

xls88

他の職種の抽出結果の貼り付け先はどうするのですか？

とりあえず
Drange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Crange, Unique:=False
を
Drange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Crange, CopyToRange:=Range("A11"), Unique:=False
として試してみてください。

貼り付け直後に出勤回数を主キーに降順でソートすればどうでしょうか。
「マクロの記録」すれば参考コードが得られると思います。
IDと職種のデータセルの入れ替えも「マクロの記録」してみてください。

お礼

すいません・・。私のVBAの進歩のなさに情けなくなります。
上記も設定してみましたが　職種のみ一覧で出る状態です。

職種ごとに出勤回数の多い順を一発で見れるようにしたいのです。

回答No.2

rukuku

＞ただし、このプログラムでは、IDと職種の列の並び替えは行いません。
表現が誤解を招くかな？と思い、補足します。
ご質問では、
元データは「IDの右に職種」、並べ替え後は「職種の左にID」となっていますがこのプログラムは、並べ替え後も「IDの右に職種」となります。という意味です。

お礼

ご回答ありがとうございます。
やってみました！　
Columns("A:D").Select
のところが　正確には　行を選択したいと考えています
A：C,Hという感じなのですがうまくいきません。

又、このデータは非常に大増量となりますので
Aの表示列、Bの表示列　と列を分けたいと考えています。

どうにか解決法はないでしょうか？

すいません・・・

回答No.1

rukuku

こんばんは

サンプルプログラムです。
A列からD列に元のデータが入っているとします。
これをH列からK列にコピーして並べ替えを行います。
ただし、このプログラムでは、IDと職種の列の並び替えは行いません。

Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/8/25 ユーザー名 : rukuku
'

'
Columns("A:D").Select
Selection.Copy
Range("H1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Key2:=Range("K2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub

実はこのプログラムは、「マクロの記録」で作りました。
「マクロの記録」は非常によい参考となります（ただ、残念ながらマクロの記録ではどうしても対応できないこともあります）。