【VBA】特定の条件でセルをコピー

ＶＢＡ初心者です
特定の条件を満たすセルの隣接する指定のセルをコピーして別のシートへ貼付けたいです


【ｓｈｅｅｔ１】

Ａ　　　Ｂ　　　Ｃ　　　～　　　Ｆ　　Ｇ

１　　　２　　　あ　　　～　　　３　　あり
２　　　１　　　い　　　～　　　７　　なし
３　　　２　　　う　　　～　　　４　　あり
５　　　３　　　え　　　～　　　６　　あり
６　　　２　　　お　　　～　　　５　　なし
７　　　１　　　か　　　～　　　３　　あり
８　　　３　　　き　　　～　　　７　　なし
９　　　２　　　く　　　　～　　８　　なし

といったデータのうち、Ｇ列が「あり」の行の
Ｃ～Ｆの値を別のシートへ以下のように貼り付けたいです

【ｓｈｅｅｔ２】

Ａ　　　～　　　Ｄ　　Ｅ

あ　　　～　　　３　　＿
う　　　～　　　４　　＿
え　　　～　　　６　　＿
か　　　～　　　３　　＿


全くの初心者です
よろしくお願いします

No.1 ベストアンサー 回答者： utun01 回答日時： 2012/04/19 18:34

Sheet1がアクティブな時しかうまくいきませんが、

こんな感じでどうでしょう。
適当に作ってるので、非常にパフォーマンス悪いですが・・・。


Public Sub cptest()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim rng As Range
Dim cel As Range
Dim stcrng As New Collection
Dim lastRow As Integer
Dim cnt As Integer
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lastRow = Range("G65535").End(xlUp).Row
Set rng = sht1.Range("G1:G" & lastRow)
For Each cel In rng
If cel.Value = "あり" Then
Set cel = sht1.Range(cel.Offset(0, -4), cel.Offset(0, -1))
stcrng.Add cel
End If
Next

sht2.Cells.Clear
cnt = 0
Set rng = sht2.Range("A1")
For Each cel In stcrng
cel.Copy
rng.Offset(cnt, 0).PasteSpecial
rng.Offset(cnt, 4).Value = "＿"
cnt = cnt + 1
Next
Application.CutCopyMode = False
End Sub

この回答へのお礼

思っていた通りのものができました
ありがとうございます
中身はまたゆっくり学んでいきます

お礼日時：2012/04/19 19:17

No.2 回答者： mar00 回答日時： 2012/04/19 19:12

Sheet2を全てクリアして、1行目からデータが始まります。

Sub Macro1()
Set ws01 = Sheets("Sheet1")
Set ws02 = Sheets("Sheet2")
ws02.Cells.ClearContents
myRow = 0
For i = 1 To ws01.Range("G65535").End(xlUp).Row
If ws01.Range("G" & i) = "あり" Then
myRow = myRow + 1
ws02.Range("A" & myRow & ":D" & myRow).Value = ws01.Range("C" & i & ":F" & i).Value
End If
Next i
End Sub

この回答へのお礼

締め切ってしまった瞬間に投稿いただきました
書式はコピーされないのでこちらはこちらで活用させていただきます
ありがとうございました

お礼日時：2012/04/19 19:18