エクセル2010 値の検索と貼り付け

エクセル2010を使っています。

画像の様な　Sheet２　があり、A列にたくさん文字が入力されています。

その中から、イニシャルテスト　の文字を探し、該当セルのT列に　Sheet3のT1～CD２５を貼り付けたいと思います。

行数は10万行ほどありますので、負担の掛からない形で貼り付けできればと思います。


イニシャルテストの文字がA1に有れば、Sheet3のT1～CD25を　Sheet2のT1に貼り付ける。

A27にも有りますので、Sheet3のT1～CD25をT27にも貼り付けます。

やりたいのは以上です、詳しい方、よろしくお願い致します。

No.2 ベストアンサー 回答者： kybo 回答日時： 2014/10/21 08:30

こんな感じだと思いますが、

T1:CD25の範囲は25行あります、イニシャルテストの文字は25以上空いて存在するのでしょうか？

Sub macro()
Dim C As Range, A As String
Set C = Range("A:A").Find("イニシャルテスト", LookAt:=xlWhole)
If Not C Is Nothing Then
A = C.Address
Do
Worksheets("Sheet3").Range("T1:CD25").Copy Range("T" & C.Row)
Set C = Range("A:A").FindNext(C)
Loop Until A = C.Address
End If
End Sub

この回答へのお礼

回答ありがとうございます。

ばっちりできました、助かりました。

仰る通り、25行以内には　イニシャルテスト　の文字は出現しませんでした、よってBAとさせて頂きます。

ありがとうございました！

お礼日時：2014/10/21 13:08

No.1 回答者： tom04 回答日時： 2014/10/20 21:51

こんばんは！

↓のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim lastRow As Long
Application.ScreenUpdating = False
With Worksheets("Sheet2")
.Rows(1).Insert
.Range("A1") = "ダミー"
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:="イニシャルテスト"
Worksheets("Sheet3").Range("T1:CD25").Copy
Range(.Cells(2, "T"), .Cells(lastRow, "T")).SpecialCells(xlCellTypeVisible).Select
Selection.PasteSpecial Paste:=xlPasteAll
.AutoFilterMode = False
.Rows(1).Delete
.Range("T1").Select
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答への補足

回答ありがとうございます。

早速試してみました。

お手数頂き、申し訳ないのですが、一つ目　A1にイニシャルテストの文字があり、それには貼り付けが出来るのでうが、その一つだけで終えてしまいます。

補足日時：2014/10/20 23:39