A列と完全一致したセルとその右隣だけを残す

質問

A列に１００００行ほど、キーワードが記入されています。

B列～Q列にもキーワードが記入されていて、
そのB列～Q列内で、A列と完全一致したセルとその右隣だけを残す（他のセルは空欄にする）
という風にしたいです。

例：
A列 B列 C列 D列 E列
東京 東京 ラーメン 大阪 ケーキ
神奈川 岡山 お好み焼き 広島 イカ焼き
静岡 沖縄 そば 石川 パスタ
大阪 滋賀 コーヒー 大阪 たこ焼き

↓
A列 B列 C列 D列 E列
東京 東京 ラーメン
神奈川
静岡
大阪 大阪 たこ焼き

このような形になるのが理想です。

これは、マクロでできるでしょうか？
どのような記述でできますか？

よろしくお願いいたします。

回答No.10

kkkkkm · ベストアンサー

東京の行に大阪とかあってもそれは削除されます、質問の例だと大阪 ケーキとかです。質問の結果がそうなっていますので。

そうではなく、東京なのに削除されるのでしたら可能性として

A列かB列の対象文字列の前後に空白があるのかもしれません。
とりあえず以下のデータだけで試してみてください。

以下のデータをA1にコピペして「データ」の「区切り位置」で「カンマやタブなどの・・・」を選んで次の所で「,」にチェックをして完了するとAからQ列までデータが分かれます。F列とG列で東京東京と何かの間違いでダブる可能性がないとも限らないのと考えてわざとダブらせています。

東京,東京,1,東京,2,東京,東京,3,大阪,4,東京,5,東京,東京,6,東京,7

大阪と4だけが削除されたのでしたら空白が存在する可能性がありますので以下のコードで試してください。

一行ごと

Sub testTrim()
Dim i As Long, j As Long, k As Long, LastRow As Long
Dim SCol As Long, ECol As Long
Dim tmp1 As Variant, tmp2 As Variant

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
SCol = Range("B1").Column
ECol = Range("Q1").Column
ReDim tmp2(ECol)

For i = 1 To LastRow
k = 0
tmp1 = Range(Cells(i, "A"), Cells(i, "Q")).Value
tmp2(0) = tmp1(1, 1)
For j = SCol To ECol
If Trim(tmp1(1, 1)) = Trim(tmp1(1, j)) Then
k = k + 1
tmp2(k) = tmp1(1, j)
If j < ECol Then
If Trim(tmp1(1, j + 1)) <> Trim(tmp1(1, 1)) Then
k = k + 1: j = j + 1
tmp2(k) = tmp1(1, j)
End If
End If
End If
Next
Cells(i, "A").Resize(1, ECol).Value = tmp2
ReDim tmp2(ECol)
Next

End Sub

最初にすべて

Sub test2Trim()
Dim i As Long, j As Long, k As Long, n As Long, LastRow As Long
Dim SCol As Long, ECol As Long
Dim tmp1 As Variant, tmp2 As Variant

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
SCol = Range("B1").Column
ECol = Range("Q1").Column
ReDim tmp2(LastRow, ECol)

tmp1 = Range(Cells(1, "A"), Cells(LastRow, "Q")).Value

For i = 1 To LastRow
k = 0
n = i - 1
tmp2(n, k) = tmp1(i, 1)

For j = SCol To ECol
If Trim(tmp1(i, 1)) = Trim(tmp1(i, j)) Then
k = k + 1
tmp2(n, k) = tmp1(i, j)
If j < ECol Then
If Trim(tmp1(i, j + 1)) <> Trim(tmp1(i, 1)) Then
k = k + 1: j = j + 1
tmp2(n, k) = tmp1(i, j)
End If
End If
End If
Next
Next

Cells(1, "A").Resize(LastRow, ECol).Value = tmp2

End Sub

英数文字や数字がある場合で全角と半角が混在している場合は

Trim(tmp1(i, 1))

のように今回Trimで囲んだところを全て以下のように変更してください。
(それぞれのコードでIfの後ろ計4か所あります。両方で8カ所)

StrConv(元のTrimで囲まれた部分,vbNarrow)

上記の場合だと以下のようになります
StrConv(Trim(tmp1(i, 1)), vbNarrow)

お礼

理想の形にできました。どうもありがとうございます。

回答No.12

kkkkkm

回答No.10の説明の訂正です。

> A列かB列の対象文字列の前後に空白があるのかもしれません。

A列かB列以降の対象文字列のどちらかの前後に空白がある、もしくは両方ともに空白にあるが数が違う、のかもしれません。

回答No.11

msMike

[No.9]の修正、
No.9 の式だけの訂正です。m(_._)m

×→_=IFERROR(INDEX(B2:N2,SMALL(IF($B2:$O2=$A8,COLUMN($B2:$O2)),1)-1),0)
￣￣￣￣￣￣￣￣￣￣￣↓↓
○→=IFERROR(INDEX(B2:$O2,SMALL(IF($B2:$O2=$A8,COLUMN($B2:$O2)),1)-1),0)

回答No.9

msMike

[No.8]の修正、
締め切られるのではアンメーかと慌てたもんで(詭弁です(*^_^*))で、呈示式の修正す。m(_._)m

G/標準;;
に書式設定し、かつ、式
=IFERROR(INDEX(B2:N2,SMALL(IF($B2:$O2=$A8,COLUMN($B2:$O2)),1)-1),0)
を入力したセル B8 を右方(O列まで)＆下方(11行目まで)にズズーッとオートフィルされたい。
【お断わり】上式は必ず配列(CSE)数式として入力のこと

回答No.8

msMike

マクロのオンパレードですが、哀しからずや、私ゃマクロ音痴なもんでスンマソンm(_._)m
添付図参照(Excel 2019)
￣￣￣￣￣￣￣￣￣￣￣￣￣↓↓↓↓↓↓↓↓↓↓↓↓↓

回答No.7

imogasi

タイプとして、検索の問題だと思う。
すると、VBAではFind,FindNext　の利用が、まあ普通に出てくる発想かと思った。
Find法は、学習には、判り難い点もあると、日頃より思っている。
質問のデータ例が列がこのサイトでは崩れやすいので、本件はよく判らないでテストした面はある。
別シートにでもデータをコピペして、そちらをActiveSheetにして、テストしてください。
A列が検索語一覧。B-Q列にデータ。
Find法は処理スピードはそんなに速くないかも。でも1万行、１０列ぐらいなら瞬く間に終わるだろう。
ーーーー
標準モジュールに
Sub test01()
Application.ScreenUpdating = False
lr = Range("A10000").End(xlUp).Row
MsgBox lr
For i = 1 To lr
x = Cells(i, "A") '検索語句設定
Set searchRng = Range("b1:Q10000") '検索範囲設定
'-------------------------
'初出を検索
Set frng = searchRng.Find(what:=x, lookat:=xlWhole)
If frng Is Nothing Then GoTo p1
fr = frng.Address
frng.Offset(0, 1).Interior.ColorIndex = 4　’該当セルの隣セルに色付け
MsgBox fr '初めに見つかったセル番地
'------------------------
'２度目以降該当箇所探索
Set mycell = frng
Do
Set mycell = searchRng.FindNext(mycell) 'FindNext
If mycell.Address = fr Then GoTo p1
MsgBox mycell.Address
mycell.Offset(0, 1).Interior.ColorIndex = 4　’’該当セルの隣セルに色付’
'初めて見つかったセルに、戻っていないか
Loop While mycell.Address <> frng.Address 'Addressで比較
'------------------
p1:
'次の語句の検索処理へ
Next i
Application.ScreenUpdating = True
End Sub

'Findメソッドは検索範囲のなかで最初に見つけたセルを返します｡
'一方､FindNextメソッドは､Findメソッドで見つけたセルの次から検索します｡
'指定範囲をすべて検索し終えたら最初に戻ることに注意してください｡
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
少数の勝手なデータでのテストなので充分でないかもしれない。
Msgbox の行は、少数のデータのテストデータ用なので、本番ではDebug.printに変えるか削除する。
データ抹消する本番では　該当以外をデータ抹消するなら、
VBA作業終了後、操作で、セルの書式で検索し、それ以外をデータを削除することになろう。

＞他のセルは空欄にする
どういうニーズなのか、理解できてないので、該当の方だけ色付けしたが、
検索語句の自体（A列以外の）語句セルデータも残すなら、もうセルの色付けのため、２行加える必要がある。
ーーー
この反転作業を嫌うなら、「セル総なめ法」が有力かも。

回答No.6

kkkkkm

回答No.4と回答No.5は間違っているやつをコピペしたようなので訂正です。

一行ずつ配列に読み込むやつ

Sub test()
Dim i As Long, j As Long, k As Long, LastRow As Long
Dim SCol As Long, ECol As Long
Dim tmp1 As Variant, tmp2 As Variant

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
SCol = Range("B1").Column
ECol = Range("Q1").Column
ReDim tmp2(ECol)

For i = 1 To LastRow
k = 0
tmp1 = Range(Cells(i, "A"), Cells(i, "Q")).Value
tmp2(0) = tmp1(1, 1)
For j = SCol To ECol
If tmp1(1, 1) = tmp1(1, j) Then
k = k + 1
tmp2(k) = tmp1(1, j)
If j < ECol Then
If tmp1(1, j + 1) <> tmp1(1, 1) Then
k = k + 1: j = j + 1
tmp2(k) = tmp1(1, j)
End If
End If
End If
Next
Cells(i, "A").Resize(1, ECol).Value = tmp2
ReDim tmp2(ECol)
Next

End Sub

最初にすべて配列に読み込むやつ

Sub test2()
Dim i As Long, j As Long, k As Long, n As Long, LastRow As Long
Dim SCol As Long, ECol As Long
Dim tmp1 As Variant, tmp2 As Variant

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
SCol = Range("B1").Column
ECol = Range("Q1").Column
ReDim tmp2(LastRow, ECol)

tmp1 = Range(Cells(1, "A"), Cells(LastRow, "Q")).Value

For i = 1 To LastRow
k = 0
n = i - 1
tmp2(n, k) = tmp1(i, 1)

For j = SCol To ECol
If tmp1(i, 1) = tmp1(i, j) Then
k = k + 1
tmp2(n, k) = tmp1(i, j)
If j < ECol Then
If tmp1(i, j + 1) <> tmp1(i, 1) Then
k = k + 1: j = j + 1
tmp2(n, k) = tmp1(i, j)
End If
End If
End If
Next
Next

Cells(1, "A").Resize(LastRow, ECol).Value = tmp2

End Sub

補足

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

マクロを試してみましたが、なぜかB列以降が全削除となります。
何かExcelの設定などが必要なのでしょうか？

回答No.5

kkkkkm

一行ずつだと遅いなと思う場合は、最初にすべて配列に読み込んで処理します。セルへの読み書きは最初に1回最後に1回の2回だけです。

Sub test2()
Dim i As Long, j As Long, k As Long, n As Long, LastRow As Long
Dim SCol As Long, ECol As Long
Dim tmp1 As Variant, tmp2 As Variant

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
SCol = Range("B1").Column
ECol = Range("Q1").Column
ReDim tmp2(LastRow, ECol)

tmp1 = Range(Cells(1, "A"), Cells(LastRow, "Q")).Value

For i = 1 To LastRow
k = 0
n = i - 1
tmp2(n, k) = tmp1(i, 1)

For j = SCol To ECol
If tmp1(i, 1) = tmp1(i, j) Then
k = k + 1
tmp2(n, k) = tmp1(i, j)
If tmp2(n, k + 1) <> tmp1(i, 1) Then
k = k + 1: j = j + 1
tmp2(n, k) = tmp1(i, j)
End If
End If
Next
Next

Cells(1, "A").Resize(LastRow + 1, ECol + 1).Value = tmp2

End Sub

回答No.4

kkkkkm

セルを一個一個読み込むのではなく一行ずつ配列に読み込んで処理して書き戻します。

Sub test()
Dim i As Long, j As Long, k As Long, LastRow As Long
Dim SCol As Long, ECol As Long
Dim tmp1 As Variant, tmp2 As Variant

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
SCol = Range("B1").Column
ECol = Range("Q1").Column
ReDim tmp2(ECol)

For i = 1 To LastRow
k = 0
tmp1 = Range(Cells(i, "A"), Cells(i, "Q")).Value
tmp2(0) = tmp1(1, 1)
For j = SCol To ECol
If tmp1(1, 1) = tmp1(1, j) Then
k = k + 1
tmp2(k) = tmp1(1, j)
If tmp2(k + 1) <> tmp1(1, 1) Then
k = k + 1: j = j + 1
tmp2(k) = tmp1(1, j)
End If
End If
Next
Cells(i, "A").Resize(1, ECol + 1).Value = tmp2
ReDim tmp2(ECol)
Next

End Sub

回答No.3

kon555

マクロというか、VBAでなら可能です。
　ちょっと面白かったのでVBAで組んでみました。
　もっとスマートなやり方もある気がしますが、一応動きます。多分10000行程度なら実用上問題ない時間で処理できるとは思います。

Sub サンプル()
Dim i As Long, j As Long, k As Long
Dim List()
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) <> "" Then
k = Cells(i, Columns.Count).End(xlToLeft).Column
v = 0
ReDim List(k - 1)
List(v) = Cells(i, 1)
For s = 2 To Cells(i, Columns.Count).End(xlToLeft).Column
If Cells(i, 1) = Cells(i, s) Then
v = v + 1
List(v) = Cells(i, s)
v = v + 1
List(v) = Cells(i, s + 1)
End If
Next s
Range(Cells(i, 1), Cells(i, k)).Value = List
End If
Next i
End Sub

　記述としては、forと配列の組み合わせです。
　WEB検索で出てくる内容で充分組める範囲なので、ご興味があれば勉強してみて下さい。

補足

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

マクロを試してみたら、なぜかB列以降が全削除になります。
これは何か別の設定などが必要でしょうか？

回答No.2

m5048172715

B列～Q列内で、A列と完全一致したセルとその右隣のセル1個だけを残すのね。

作戦を同じシート内でのVBA（VBAを使う）とすると、for～next, cells, ifステートメントだけでできる。VBA抜きでやる方が大変で、見にくいような気がする。