みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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位まで変動します

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

投稿日時 - 2007-04-04 07:55:32

QNo.2892589

困ってます

質問者が選んだベストアンサー

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

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

投稿日時 - 2007-04-05 17:50:46

お礼

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

投稿日時 - 2007-04-06 00:32:15

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

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

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

投稿日時 - 2007-04-04 10:03:53

補足

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

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

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

投稿日時 - 2007-04-05 07:32:32

あなたにオススメの質問