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

質問

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

【ｓｈｅｅｔ１】

Ａ　　　Ｂ　　　Ｃ　　　～　　　Ｆ　　Ｇ

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

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

【ｓｈｅｅｔ２】

Ａ　　　～　　　Ｄ　　Ｅ

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

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

回答No.1

utun01 · ベストアンサー

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

お礼

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

回答No.2

mar00

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

お礼

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