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

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

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

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

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

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

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

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

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2023/06/21 15:46

Range("A1").CurrentRegion.ClearContentsでA列も消しているので

#2の処理でA列の値が残っていると言う事は
arrAns(r, 1) = Arr(r, 1)は処理されて、IF内の処理が行われていませんので
If Arr(r, 1) = Arr(r, c) Thenの条件に合わないと言う事になります

つまり
そのB列～Q列内で、A列と完全一致した（例の場合、同じ行単位の全角文字列）が無いと言う事になります

（見かけ上あるけれど　実際の値が違う場合もあるかな）
半角全角スペースが有ったり、改行コードが有ったり、依存文字が有ったり・・・
実際の値（文字列）を調べる必要がありそうです

実際の文字列はどのように取得（書き込み）しているのでしょう
インポート　数式　コピペ　手入力

実際の文字列はどのようなものですか・・

取り合えずミニマムなコードを作り　比較検証してみてください

Sub test_03()
Dim r As Range, c As Long
For Each r In Range("A1", Cells(Rows.Count, 1).End(xlUp))
For c = 1 To 17
If r.Value = r.Offset(, c).Value Then
MsgBox r.Value
DoEvents
End If
Next
Next
End Sub

　値が合っていれば　MsgBox r.Value　が出力される
DoEventsを入れているので　ESCボタンで中断できると思います

No.2 回答者： Qchan1962 回答日時： 2023/06/21 11:04

＃１です

気になっていたので　10000行ほどデータを作り試しましたが
＃１はさすがに使い物にならなさそうでしたので　書き直しました
配列を使い　データを取得し当該条件によりデータを再構成（加工）を行い出力しています
他のシートへの出力も出来るので良いかも知れません

＞他のセルは空欄にす＞
左に詰めている解釈でしたが合っていますか？

下記コードにおいて
空白セルにしたい場合は条件にElseを設けてarrAns配列に空白（0文字数の値）を入れます

Sub test_02()
Dim r As Long, c As Long, n As Long
Dim rSize As Long, cSize As Long
Dim Arr As Variant, arrAns As Variant

Arr = Range("A1").CurrentRegion
rSize = UBound(Arr, 1)
cSize = UBound(Arr, 2)

ReDim arrAns(1 To rSize, 1 To cSize)
For r = 1 To rSize
arrAns(r, 1) = Arr(r, 1)
n = 1
For c = 2 To cSize
If Arr(r, 1) = Arr(r, c) Then
n = n + 1
arrAns(r, n) = Arr(r, c)
n = n + 1
c = c + 1
arrAns(r, n) = Arr(r, c)
End If
Next c
Next r
Application.ScreenUpdating = False
Range("A1").CurrentRegion.ClearContents
Range("A1").Resize(UBound(arrAns, 1), UBound(arrAns, 2)) = arrAns
Application.ScreenUpdating = True
End Sub

この回答へのお礼

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

書いていただいたマクロを試してみましたが、
なぜかB列以降が全削除されてしまいます。

何か他のExcelの設定などが必要だったりするのでしょうか？

お礼日時：2023/06/21 15:13

No.1 回答者： Qchan1962 回答日時： 2023/06/21 09:02

こんにちは

一致しているか条件分岐して
順番に不一致セルを取得して　取得範囲を最後に削除し左に詰める処理です

最後に纏めて削除しているので少しはマシかも知れませんが
データ数によってはそれなりの時間を要すかと・・・

Sub test_01()
Dim r As Long, c As Long
Dim delRange As Range
For r = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For c = 2 To Cells(r, Columns.Count).End(xlToLeft).Column
If Cells(r, 1) = Cells(r, c) Then
c = c + 1
Else
If delRange Is Nothing Then
Set delRange = Cells(r, c)
Else
Set delRange = Union(delRange, Cells(r, c))
End If
End If
Next c
Next r
If Not delRange Is Nothing Then delRange.Delete Shift:=xlToLeft
End Sub