エクセルVBA条件セル検索時連続時処理中止と列複数

質問

いつもお世話になっております。
Excel2013のVBAでまた質問があります。お願いいたします。

ある表のにある値が入力されていたら、その値をコピーして1行上の4列右の列に貼り付け、もとの行の値を削除するように色々参考にしながら作りました。

ある値を例えば、"AAA”と"BBB"だとして、下記コードでなんとか最初の段階が実現できました。
あと、やりたいのは、条件を検索する列の、"AAA"もしくは"BBB"の値が連続している場合は、メッセージを出して、処理を中止にしたいです。単体で連続でも２つの組み合わせでも、この２つのうちいずれかが入力されている行が続いていたら中止です。

あと、最初にWorksheets("Sheet1").UsedRange.Columns(5)列目を指定しているんですが、実際は、複数の列を指定したいです。コピーしたり消去したりのオフセットの位置関係は変わりません。
必要なら、名前を定義して、一括で指定するのも大丈夫です。

お手数をおかけしますが、ご教授よろしくお願いいたします。

Sub TEST()
Dim c As Range
Dim firstAddress As String
' ActiveSheet.UsedRange.Select

With Worksheets("Sheet1").UsedRange.Columns(5)

Set c = .Find(What:="AAA", _
LookIn:=xlValues, LookAt:=xlWhole)

If Not c Is Nothing Then
firstAddress = c.Address

Do
Range(c.Address, Range(c.Address).Offset(0, 1)).Copy Range(c.Address).Offset(-1, 4)
Range(Range(c.Address).Offset(0, -1), Range(c.Address).Offset(0, 6)).ClearContents

Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If

'別条件でもう一度
Set c = .Find(What:="BBB", _
LookIn:=xlValues, LookAt:=xlWhole)

If Not c Is Nothing Then

firstAddress = c.Address

Do
Range(c.Address, Range(c.Address).Offset(0, 1)).Copy Range(c.Address).Offset(-1, 4)
Range(Range(c.Address).Offset(0, -1), Range(c.Address).Offset(0, 6)).ClearContents

Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
End Sub

回答No.1

keithin · ベストアンサー

＞実際は、複数の列を指定したいです

具体的にどこ列範囲を対象にしたいのでしょう。
ＡＡＡやＢＢＢは右４の列に「コピー」されますから、不定の列からＡＡＡ・ＢＢＢを探して上１右４にコピーしたのを「対象から外す」必要があるハズです。その辺の、やるヤラナイ列関係の条件がありませんね。

また複数列を対象にした際、「連続する」のが縦に繋がってる限定でいいのかちょっと曖昧です。
データが実際に何行から開始されてるのかも情報がありません。

sub macro1()
　dim a as variant
　dim buf as variant
　dim c as range

　a = array("AAA", "BBB")
　with worksheets("Sheet1").range("D:F")　’仮にＤ，Ｅ，Ｆ列

　for each buf in a
　　set c = .find(what:=buf, lookin:=xlvalues, lookat:=xlwhole)

　　do until c is nothing　’全部処理して無くなるまでループ

　　’一つ上と一つ下を検査
　　　if not iserror(application.match(c.offset(-1).value, a, 0)) _
　　　or not iserror(application.match(c.offset(1).value, a, 0)) then
　　　　c.offset(-1).resize(3, 1).select
　　　　msgbox "STOP"
　　　　exit sub
　　　end if

　　　c.offset(-1, 4).value = c.value　’上１右４に転記
　　　c.offset(0, -1).resize(1, 7).clearcontents　’左１から７セル消去
　　　set c = .findnext(c)
　　loop
　next
　end with
end sub

補足

>具体的にどこ列範囲を対象にしたいのでしょう。
F列、次にO列、X列・・・と続きます。検索は4行目からになります。列でいくとF4から始まりF23で終わり、再びF30:F49、F56:F75と続きますが列全体で指定しても問題ないです。

F列で考えると、ＡＡＡ・ＢＢＢを探してF列、G列をコピーしたものは上１右４にあたるJ列、Ｋ列に貼り付けるようになります。

列、次にO列、X列・・・を対象で離れてた列なので、「連続する」のが縦に繋がってる場合限定で横に並ぶ事はありません。
今書いていて思ったのがF4にもしあった場合も、処理をストップさせる必要がありました。

言葉足らずで、いつも色々な想定をさせてしまってすいません。なかなか自分目線で想定不足です。
ご迷惑をおかけします。
すいません、以下の所の指定がわかりませんでした。F列、O列、X列を指定するにはどうすればよろしいでしょうか？

　with worksheets("Sheet1").range("D:F")

後は、動きは想定したもので問題なさそうでした。複数指定もまとめていただきコンパクトになりとてもありがたいです。

回答No.2

keithin

ご相談にあれもこれも詰め込みしてるので、状況説明も足らず回答も薄くなります。
元々のご質問内容の「連続してたら打ち切り」が解決したのでしたら、それで一回終了して欲しいです。

ホントにＦ，Ｏ，Ｘ列でいいのか疑問ですが、自力で適切に応用してください。
変更前：
with worksheets("Sheet1").range("D:F")　’仮にＤ，Ｅ，Ｆ列

変更後：
with worksheets("Sheet1").range("F:F,O:O,X:X")　
あるいは
with worksheets("Sheet1").range("対象範囲の名前定義")　

それからこれも、ご相談に何の説明もありませんが。
変更前：
c.offset(-1, 4).value = c.value　’上１右４に転記

変更後：
c.offset(-1, 4).resize(1, 2).value = c.resize(1, 2).value

お礼

お手数をおかけしてすいませんでした。
見事にできました。
どうもありがとうございました。