プログラムの作り方

質問

まったくの素人です。
1列にあるデータをキーにして情報の抽出をしたいのですが
うまくコードが書けません。
何卒、助勢頂ければ幸いです。
よろしくお願いいたします。
具体的な内容)
B列　C列
x　　11
・・適当な不要なデータが数行
y 　(2A)
・・適当な不要なデータが数行
x　　12
・・適当な不要なデータが数行
y 　(44)
・・適当な不要なデータが数行
x　　39
・・適当な不要なデータが数行
y 　(7)
・・適当な不要なデータが数行
から、xのデータとyのデータの表を作りたい。
ただし、yのデータ()内はB列のyの次の行。
できれば、抽出したデータはシート2に並べたい。
Sub macro()
Dim a As String
Dim b As Variant
Dim c As range
Dim i As Integer
a = x
b = "y"
i = 1
Worksheets("sheet1").range("B1").Activate
For i = 1 To 5000
With ActiveCell
If .Value = a Then
ActiveCell.Offset(0, 1).Copy
Worksheets("sheet2").Select
Cells(i, 1).Select
ActiveSheet.Paste
Sheets("sheet1").Select
Else
ActiveCell.Offset(1, 0).Activate
End If
If .Value = b Then
ActiveCell.Offset(1, 0).Copy
Worksheets("sheet2").Select
Cells(i, 2).Select
ActiveSheet.Paste
Sheets("sheet1").Select
Else
ActiveCell.Offset(1, 0).Activate
End If
End With
Next
End Sub

回答No.7

o_chi_chi · ベストアンサー

#6です。
少し勘違いしてました。
Sheet2はAにx、Bにyですね。
--
Sub Macro1()
Dim x As String '変数の定義
Dim y As String
Dim i As Long
Dim j As Long
j = 0
x = 10 'キーワードの割り当て
y = "AA"
With Worksheets("Sheet1")
For i = 1 To 5000 'ループ検索
Select Case True
Case .Cells(i, 2).Value = x
j = j + 1
Worksheets("Sheet2").Cells(j, 1).Value = .Cells(i, 3).Value
Case .Cells(i, 2).Value = y
Worksheets("Sheet2").Cells(j, 2).Value = .Cells(i + 1, 2).Value
Case Else
End Select
Next i
End With
End Sub

お礼

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

動作確認しました。
完璧でした。。
ありがとうございます。

小生のプログラムとは異なりすっきりしており
処理時間が断然早くなりました。びっくりしました。

本当にありがとうございます。
プログラムを見ると、なるほどこれでいいんだなと
動作は分かる（つもり？）のですが、
自分で作る時は全く思いつきませんでした。
もっと、色々見てさらに勉強していきます。