ある条件を満たすセルに対応する行のセル内容をコピーして・・

ある条件を満たすセルに対応する行のセル内容をコピーして・・

　いつもお世話になっております。エクセルVBAのほぼ初心者です。

ある列の一部（たとえばE100～200）において、ある条件を満たすセル（たとえば<30）を
すべて検索して（たとえばE110とE130）、そのセルの行にある別列のセル内容（たとえば
A110とB110、およびA130とB130）をコピーして、別のワークシートのとある場所（たとえ
ばB2）に貼り付ける。

　というようなマクロを作成したいのですが、自分の力量では難しいのです。。
　Do～Loopなどを利用すればよいのでしょうか？
　いい方法がありましたらどうぞよろしくお願いいたします。

No.2 ベストアンサー 回答者： end-u 回答日時： 2010/06/17 13:07

Excelに元々備わっている機能を使うなら

Sub Macro1()
　　Dim r As Range
　　
　　With Sheets("sheet1") '元シート
　　　　Set r = .Range("E99:E200") '検索範囲+直上行
　　　　.AutoFilterMode = False
　　　　'AutoFilterで抽出条件設定
　　　　r.AutoFilter Field:=1, Criteria1:="1"
　　　　If r.SpecialCells(xlCellTypeVisible).Count = 1 Then
　　　　　　MsgBox "no data"
　　　　Else
　　　　　　Intersect(r.Offset(, -4), r.Offset(1, -4)).Resize(, 2).Copy _
　　　　　　　　　　　Sheets("sheet2").Range("B2") 'コピー先
　　　　End If
　　　　.AutoFilterMode = False
　　End With

　　Set r = Nothing
End Sub

こんな感じもあります。
シート名やアドレス等は適宜修正してください。
コピー先に既存データがあるなら、コピー前にクリア処理も必要かと。

この回答へのお礼

難しく考えすぎていました。。
そうですよね。オートフィルターを利用すれば割と簡単にマクロが作れますね。

アドバイスありがとうございました。

お礼日時：2010/06/21 17:49

No.3 回答者： YON56 回答日時： 2010/06/18 10:11

「ある条件(<30)を満たす値を、指定した範囲(E100～E200)から抽出し、そのセルの位置(行・列)情報を基に

特定のセル(B列とします)の値を特定のセル(1000～1000+条件を満たすセル値の個数行目のC列)に入力する。」として、回答します。

マクロを記述する前にマクロを記述し易くするための準備をします。
同一シートのセルZ100に[=IF(B100<30,"S","")]と入力し、Z101～Z200にコピーし貼り付けます。
Z列をクリックし、書式設定より非表示にします。

マクロを書きます

Dim A,B,C
A=Application.WorksheetFunction.CountIf("S", Range("Z100:Z200"))
B=0
For C=1 To A
B=B+ Application.WorksheetFunction.Match("S", Range(Cells(B + 1, 26), Cells(200,26)), 0)
Cells(1000+B,3)=Cells(B,2).Value
Next C

"S"は目印、Z列は目印置場と考えて下さい。目印及び目印置場は使用者が勝手に決めて下さい。

また、目印を[=CountIf("E$100:E100")]として、
A=Application.WorksheetFunction.Max(Range("Z100:Z200"))
B=B+ Application.WorksheetFunction.Match(B, Range(Cells(C + 1, 26), Cells(200,26)), 0)
のように記述しても同じことです。

入力するシートがSheet2とすれば、
Sheets("Sheet2").Cells(1000+B,3)=Cells(B,5).Value
となります。

ついでに、入力するシートが別のファイルXXXのSheet2とすれば、
Workbooks("XXX").Sheets("Sheet2").Cells(1000+B,3)=Cells(B,5).Value
となります。

No.1 回答者： crossgate 回答日時： 2010/06/17 12:48

コピー先をどうするのか良く分からないけど（結果をくっつけて１つのセルにいれるのか？）、こんなのでどうですか？

とりあえずコピー元のセルはくっつけずにそのままコピー先のセルに入れるようにしてみました。

---------------------------------------
Sub hoge()

Dim MotoRowNum As Integer 'コピー元シートの行カウンタ
Dim SakiRowNum As Integer 'コピー先シートの行カウンタ

'コピー先シートの行カウンタを初期化
SakiRowNum = 1
'コピー元シートの100～200行目をチェック
For MotoRowNum = 100 To 200
'コピー元ブックの1シート目のE列が30未満か判定
If ActiveWorkbook.Sheets("Sheet1").Cells(MotoRowNum, 5) < 30 Then

'コピー元シートのA列からコピー先シートのA列にコピー
ActiveWorkbook.Sheets("Sheet2").Cells(SakiRowNum, 1) = _
ActiveWorkbook.Sheets("Sheet1").Cells(MotoRowNum, 1)

'コピー元シートのB列からコピー先シートのB列にコピー
ActiveWorkbook.Sheets("Sheet2").Cells(SakiRowNum, 2) = _
ActiveWorkbook.Sheets("Sheet1").Cells(MotoRowNum, 2)

'コピーしたときだけコピー先シートの行カウンタをUP
SakiRowNum = SakiRowNum + 1
End If
Next
End Sub