VBA 条件合致の場合、セルを別シートへ抜き出す

こんにちは
条件に合う文字列があった場合に該当するシートへ順番にセルをコピーをしたいです。
調べながら作成したものではうまくいかず、皆様の知識をお借りしたいと思い投稿させて頂きました。
目的：シート”dddd”の1列目6行目以下～を参照し
①aaaaがあった場合はシートaaaaの2列目8行目から順に転記
⓶bbbbがあった場合はシートbbbbの〃
③ccccがあった場合はシートccccの〃
を行いたいと考えています。（操作はシートddddで行っています）
色々見ながら下記で操作したところ繰り返し作業が行われない状態でどの様にしたら良いかわからず
投稿させて頂きました。　お手数ですがご指摘アドバイスなど宜しくお願い致します。
Sub tenki3()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim i As Variant
Dim j As Variant

Set ws1 = Worksheets("aaaa")
Set ws2 = Worksheets("bbbb")
Set ws3 = Worksheets("cccc")
Set ws4 = Worksheets("dddd")

lRow = ws4.UsedRange.Rows.Count

For i = 6 To Cells(Rows.Count, 1).End(xlUp).Row
j = 8

If Cells(i, 1) = "aaaa" Then
ws1.Cells(j, 1) = ws4.Cells(i, 2)

End If
j = 8 + 1
Next i

End Sub

No.4 回答者： tom04 回答日時： 2020/08/06 18:32

No.2です。

＞転記先のセルを8行目にするためには・・・
というコトですが、前回投稿した中に
＞（各シートのA7セルには項目名が入っている！という前提です）
という大前提がありましたよね。

＞wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) = .Cells(i, "B")
でA列の最終行の一つ下のセルに順に該当データを表示するようにしていますので、
A7セルに項目など何らかのデータがないととんでもないところに表示されてしまいます。

A7セルに何もデータがない場合は変数を一つ増やして
行を指定するしかないかも・・・m(_ _)m

この回答へのお礼

なるほど、再度のご回答有難うございます。
再度色々試してみます。
ご丁寧に教えて頂き有難うございました。

お礼日時：2020/08/12 09:25

No.3 回答者： Qchan1962 回答日時： 2020/08/03 19:02

こんにちは、

すでに回答が出ていますが、参考までにオートフィルタの場合のサンプルです。
Sub Sample3()
　　Dim lRow As Long
　　Dim keyword
　　With Worksheets("dddd")
　　　　lRow = .UsedRange.Rows.Count
　　　　For Each keyword In Array("aaaa", "bbbb", "cccc")
　　　　　　If Application.CountIf(.Range("A6:A" & lRow), keyword) > 0 Then
　　　　　　　　.UsedRange.AutoFilter Field:=1, Criteria1:=keyword
　　　　　　　　.Range("B6:B" & lRow).SpecialCells(xlCellTypeVisible).Copy Sheets(keyword).Range("B8")
　　　　　　　　.AutoFilterMode = False
　　　　　　End If
　　　　Next
　　End With
End Sub
セルの書式もコピーされます。
値のみの場合は、PasteSpecialメソッドの Paste:=xlPasteValues
Application.CutCopyMode = False
に変更、追加してください。

この回答へのお礼

ご回答有難うございます。
オートフィルタにて作成してみたところ、書式が違うためコピーできないと出てしまうため現在奮闘中です。
御教授頂き有難うございました。

お礼日時：2020/08/12 09:23

No.2 回答者： tom04 回答日時： 2020/08/03 18:18

こんにちは！

余計なお世話かもしれませんが・・・
＞（操作はシートddddで行っています
とありますが、「dddd」シートのシートモジュールにしているのでしょうか？

複数のシートにわたって操作する場合は「標準モジュール」にした方がエラーが少ないと思います。
（もちろん、シートモジュールでもエラーなく動くことも多くあります）

さて本題ですが、「dddd」シートのA列には各シート名が入っているのでしょうかね。

一例です。
（各シートのA7セルには項目名が入っている！という前提です）

Sub Sample1()
　Dim i As Long, k As Long
　Dim wS As Worksheet
　Dim myFlg As Boolean
　Dim myAry

　　myAry = Array("aaaa", "bbbb", "cccc")
　　　With Worksheets("dddd")
　　　　For i = 6 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　For k = 0 To UBound(myAry)
　　　　　　If .Cells(i, "A") = myAry(k) Then
　　　　　　　myFlg = True
　　　　　　　Exit For
　　　　　　End If
　　　　　Next k
　　　　　　If myFlg = True Then
　　　　　　　Set wS = Worksheets(myAry(k))
　　　　　　　　wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) = .Cells(i, "B")
　　　　　　End If
　　　　　　　myFlg = False
　　　　Next i
　　　End With
End Sub

※　データ量が多い場合は、No.1さんが回答されている
オートフィルタの方が速いかも・・・m(_ _)m

この回答へのお礼

tom04様
とてもまとまった式を記載していただき有難うございます。
ご指摘の通り標準モジュールにて運用予定です。
1点ご質問させて下さい。　記載していただいた内容にて動作致しましたが、転記先のセルを8行目にするためにはどうしたらよいでしょうか？
ご質問ばかりで申し訳ありません。　
（記載内容のなかで色々試してみましたが触れば触るほど動作しなくなって
しまいました）

お礼日時：2020/08/06 18:16

No.1 回答者： めぐみん_ 回答日時： 2020/08/03 13:03

どのシートへの値が見つかってもそうでなくても変数：j はドンドン加算されていきますしね。

http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/v …

オートフィルタを使い１つの値で抽出しそのシートにコピペ。
一旦解除して次の値で同様に、更に次の値でって感じでやっては如何でしょう。
フィルタをかける位置・貼り付ける位置に注意していけば可能な気もしますよ。
過去の質問でもいくつかはあると思いますし。（Autofilterで検索してみると）

この回答へのお礼

ご助言ありがとうございます。
サイトも参考にして取り組んでみます

お礼日時：2020/08/06 10:37