マクロの記述をもっとシンプルにしたい

このサイトでいただいた回答を利用し、また、マクロの記録を使って切り貼りして何とかやりたいことができるようになったマクロですが、記述に無駄があると思います。どのように書きかえるともっとスマートになるでしょうか。
作ったのは、１９０数名の数学と英語の点数を入力し、オートフィルタを使ってまず、数学の100点満点を取ったものを抽出します。そのリストをコピーし、隣のシートにコピーします。次に同じく数学ですが、60点未満のものを抽出し、それをコピーし、隣のシートのさっきコピーした隣にコピーします。それからオートフィルタを解除して、同じことを英語にも行います。最後に4つの表が並んだシートの不要な列を削除し、タイトルをつけ、列幅を調節し、オートフィルタを解除して終了します。

以下にマクロの記述をコピーします。まだなステイトメントばかりだと思いますので、アドバイスお願いいたします。

Sub 条件生徒抽出シンプル版new()

Dim wS As Worksheet
Set wS = Worksheets("Sheet2")

wS.Cells.Clear

With Range("A1").CurrentRegion

.AutoFilter field:=5, Criteria1:=100 '数学の満点者を抽出
.Copy wS.Range("A1") '上のリストをコピー
.AutoFilter field:=5, Criteria1:="<60" '数学の不合格者を抽出
.Copy wS.Range("h1") '上のリストをコピー

Selection.AutoFilter '元データリストのオートフィルタを解除
.AutoFilter field:=6, Criteria1:=100 '英語の満点者を抽出
.Copy wS.Range("o1") '上のリストをコピー
.AutoFilter field:=6, Criteria1:="<60" '英語の不合格者を抽出
.Copy wS.Range("v1") '上のリストをコピー

End With

Sheets("Sheet2").Select
Range("A:A,F:F,H:H,M:M,O:O,S:S,V:V,Z:Z").Select
Selection.Delete 'コピーした表の不要な列を削除
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'タイトル行を追加
Range("A1").Select
ActiveCell.FormulaR1C1 = "数学満点者"

Range("F1").Select
ActiveCell.FormulaR1C1 = "数学不合格者"

Range("K1").Select
ActiveCell.FormulaR1C1 = "英語満点者"

Range("P1").Select
ActiveCell.FormulaR1C1 = "英語不合格者"

Rows("2:2").Select

Selection.HorizontalAlignment = xlCenter '追加したタイトルをセンタリング


Columns("A:A").ColumnWidth = 4.63 '各列の幅を変更
Columns("C:C").ColumnWidth = 12
Columns("C:C").ColumnWidth = 12.75
Columns("D:D").ColumnWidth = 6.38
Columns("F:F").ColumnWidth = 4.63
Columns("H:H").ColumnWidth = 12.75
Columns("I:I").ColumnWidth = 6.38
Columns("K:K").ColumnWidth = 4.63
Columns("M:M").ColumnWidth = 12.75
Columns("N:N").ColumnWidth = 6.38
Columns("P:P").ColumnWidth = 4.63
Columns("R:R").ColumnWidth = 12.75
Columns("S:S").ColumnWidth = 6.38


Sheets("今週の点数").Select
Selection.AutoFilter 'オートフィルタを解除

End Sub

No.3 ベストアンサー 回答者： soixante 回答日時： 2013/11/03 11:32

Sheet2にデータをコピー、列削除後に、わざわざ１行下に落とすなら、最初から２行目にコピーしたほうがよいような気が。

＞Range("A1").Select
＞ActiveCell.FormulaR1C1 = "数学満点者"

これについては＃１さんのご指摘通り。無駄なSelectはしない、という以下記事を。
http://officetanaka.net/excel/vba/speed/s2.htm

最後の列幅変更は同じものをまとめるといいのでは。
私は、列番号で、For Next で回し、列番号のSelect Case　で処理することが多いです。
（列削除も同じ形にしています。行削除も列削除もケツからが鉄則なので、ループカウンタは逆回しです。）

いちおう以下ご参照ください。

※私のテスト時には、あなたのコードで処理したものと、全く同じものができました。
トライ時はバックアップのうえお願いします。
********************************************************************************
Sub Test条件生徒抽出シンプル版new()

Dim wS1 As Worksheet, ws3 As Worksheet
Dim i As Integer, j As Double
Set wS1 = Worksheets("今週の点数")
Set ws3 = Worksheets("Sheet3")

Application.ScreenUpdating = False
ws3.Cells.Clear
wS1.Select

With wS1.Range("A1").CurrentRegion

.AutoFilter field:=5, Criteria1:=100
.Copy ws3.Range("A2")
.AutoFilter field:=5, Criteria1:="<60"
.Copy ws3.Range("h2")
ActiveSheet.AutoFilterMode = False

.AutoFilter field:=6, Criteria1:=100
.Copy ws3.Range("o2")
.AutoFilter field:=6, Criteria1:="<60"
.Copy ws3.Range("v2")
End With

ws3.Select

For i = 28 To 1 Step -1
Select Case i
Case 1, 6, 8, 13, 15, 19, 22, 26
Columns(i).Delete
End Select
Next i

Range("A1").Value = "数学満点者"
Range("F1").Value = "数学不合格者"
Range("K1").Value = "英語満点者"
Range("P1").Value = "英語不合格者"

Rows(2).HorizontalAlignment = xlCenter

For i = 1 To 21
Select Case i
Case 1, 6, 11, 16
j = 4.63
Case 3, 8, 13, 18
j = 12.75
Case 4, 9, 14, 19
j = 6.38
Case Else
j = Columns(i).ColumnWidth
End Select
Columns(i).ColumnWidth = j
Next i

wS1.Select
ActiveSheet.AutoFilterMode = False

Application.ScreenUpdating = True
Set wS1 = Nothing
Set ws3 = Nothing

End Sub

この回答へのお礼

　大変詳しく教えていただきありがとうございました。select caseステイトメントというもの学ぶことができました。また、画面がちらつく動作を消すことや、最後にオブジェクトのリンクを解除することなど、基本を覚えることができました。
本当にありがとうございます。

お礼日時：2013/11/03 15:42

No.2 回答者： bin-chan 回答日時： 2013/11/03 11:22

ColumnWidthもか。

C列への定義がダブリ。
同じ列幅はまとめられませんか？
Range("A:A,F:F,K:K,P:P).ColumnWidth = 4.63

No.1 回答者： bin-chan 回答日時： 2013/11/03 10:49

Range("A1").Select

ActiveCell.FormulaR1C1 = "数学満点者"
を
Range("A1") = "数学満点者"
にするくらい？

この回答へのお礼

早速のご回答ありがとうございました。
シンプルに記述する基本を学ぶことができました。
本当にありがとうございます。

お礼日時：2013/11/03 15:43