Excelでマクロを繰り返したい。

質問

Excelでマクロを記録したら以下のようになりました
このマクロを以下の条件で繰り返したいのですが。

Sub Macro1()
'-------------
'-----------------------
'
Sheets("Sheet1").Select
Selection.AutoFilter Field:=4, Criteria1:="=5*", Operator:=xlAnd, _
Criteria2:="<>5@*"
Range("A3:A302").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Range("A1").Select
Selection.AutoFilter Field:=4, Criteria1:="=6*", Operator:=xlAnd, _
Criteria2:="<>6@*"
Range("A3:A302").Select
Selection.Copy
Sheets("Sheet2").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Selection.AutoFilter Field:=4, Criteria1:="=7*", Operator:=xlAnd, _
Criteria2:="<>7@*"
Range("A3:A302").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A103").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Range("A1").Select
Selection.AutoFilter Field:=4, Criteria1:="=8*", Operator:=xlAnd, _
Criteria2:="<>8@*"
Range("A3:A302").Select
Selection.Copy
Sheets("Sheet2").Select
Range("B103").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub

条件＝　Field：は4～35位まで変動します

一連の動作をコピーして手作業で数字を変えてみたのですが
プロージャが大きすぎてエラーになってしまいます。
何か良い方法は無いでしょうか？。

回答No.2

cafe_au_lait · ベストアンサー

検索条件のループをはずして、貼り付け位置の設定を変更しました。

Sub sample()

Dim RngOrg As Range
Dim RngNew As Range
Dim m As Integer
Dim n As Integer

Set RngOrg = ThisWorkbook.Worksheets("Sheet1").Range("A3:A302") 'コピーする範囲
n = 5 '検索条件の数字
Set RngNew = ThisWorkbook.Worksheets("Sheet2").Range("A3") '最初

For m = 4 To 35 'フィールドの範囲

RngOrg.AutoFilter Field:=m, Criteria1:="=" & n & "*", Operator:=xlAnd, _
Criteria2:="<>" & n & "@*"

RngOrg.Copy
RngNew.PasteSpecial Paste:=xlPasteValues

Set RngNew = RngNew.Offset(, 1)

RngOrg.Worksheet.AutoFilterMode = False 'オートフィルタを解除

Next m

End Sub

お礼

どうもありがとうございました。
わかりやすく書いていただいて感謝しております。
今回の回答を参考にいろいろ手を加えて、幅を広げていきたいと思います。大変お世話になりました、また機会がありましたらよろしくお願い致します。

回答No.1

cafe_au_lait

希望する動作を把握できていないかもしれませんが・・・。

Sub sample()

Dim RngOrg As Range
Dim RngNew As Range
Dim m As Integer
Dim n As Integer

Set RngOrg = ThisWorkbook.Worksheets("Sheet1").Range("A3:A302") 'コピーする範囲

For m = 4 To 35 'フィールドの範囲
For n = 5 To 8 '検索条件の数字

RngOrg.AutoFilter Field:=m, Criteria1:="=" & n & "*", Operator:=xlAnd, _
Criteria2:="<>" & n & "@*"

'ペーストのルールがいまいち把握できていませんが・・・。
'とりあえず、A3,B3,A103,B103,A203,B203,A303,B303・・・と続くものとしました。

If m = 4 And n = 5 Then '最初
Set RngNew = ThisWorkbook.Worksheets("Sheet2").Range("A3")
ElseIf n Mod 2 Then 'nが奇数のとき
Set RngNew = RngNew.Offset(100, -1)
Else 'nが偶数のとき
Set RngNew = RngNew.Offset(, 1)
End If

RngOrg.Copy
RngNew.PasteSpecial Paste:=xlPasteValues

Next n

RngOrg.Worksheet.AutoFilterMode = False 'オートフィルタを解除

Next m

End Sub

補足

すいません　質問の仕方が悪かったようです。
条件を少し変えてみます。

- 検索する数字をひとつにする
- フィールドは4から35まで
- コピーする範囲はそのまま
- ペーストするセルはA3,B3,C3・・・・・とする

お手数ですがよろしくお願いします。