特定文字を検索し、その行の座標を別のセルへ移す

質問

特定文字を検索し、その行の座標を別のセルへ移すには、エクセルVBA では
どのようなコードを記入すればよろしいでしょうか？

H列に記入されている「：Q」がある行を検索します。（黄枠）
その行を確認すると番地の列にA10(緑枠）、A30（赤枠）という文字があります。
８行目と10行目の同じように番地の箇所にA10又はA30と記入してある行の
I,J,K,Lに(緑枠）、（赤枠）の行のXとYの座標を移動できないでしょうか？
・移動先行のＨ列は必ず「：M」と記入してあります
・座標を移動した後は、最終的に「：Q」の行は削除します
・図では、４行目の座標がK,L、５行目の座標がI,Jに来ていますが、逆でも大丈夫です。
（６,７行目も同じです）

エクセルは2007を使用しております。
よろしくお願い致します。

回答No.1

KURUMITO

次のようなマクロにすればよいでしょう。

Sub 試験()
Dim i, n As Integer
Application.ScreenUpdating = False
i = 1
Do
i = i + 1
If Range("H" & i) = ":Q" Then
n = i
Do
n = n + 1
If Range("H" & n) = ":M" Then
Range("K" & n) = Range("A" & i).Value
Range("L" & n) = Range("C" & i).Value
Range("I" & n) = Range("A" & i + 1).Value
Range("J" & n) = Range("C" & i + 1).Value
Range("K" & n + 1) = Range("A" & i + 2).Value
Range("L" & n + 1) = Range("C" & i + 2).Value
Range("I" & n + 1) = Range("A" & i + 3).Value
Range("J" & n + 1) = Range("C" & i + 3).Value
Range("A" & i & ":A" & i + 3).EntireRow.Delete xlShiftUp
Exit Do
End If
Loop Until Range("H" & n) = ""
i = i + 3
End If
Loop Until Range("H" & i) = ""
Application.ScreenUpdating = True
End Sub

お礼

勉強になります。
ありがとうございました。