エクセルのセル内の重複文字列処理について

こんばんは！

VBAになってしまいますが、一例です。

データは1行目からあるとします。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i As Long
Dim k As Long
Dim tmp As Variant
Dim myArray As Variant
Application.ScreenUpdating = False
Columns(2).ClearContents
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
tmp = WorksheetFunction.Substitute(Cells(i, 1), "　", " ")
If InStr(tmp, " ") > 0 Then
myArray = Split(tmp, " ")
For k = 0 To UBound(myArray)
If InStr(Cells(i, 2), myArray(k)) = 0 Then
Cells(i, 2) = Cells(i, 2) & myArray(k) & " "
End If
Next k
Else
Cells(i, 2) = Cells(i, 1)
End If
Next i
Application.ScreenUpdating = True
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

こんにちは。

お邪魔します。

　　＜元データ　ダミーサンプル＞　Ａ列
■みかん 　 りんご 　バナナ　　りんご　みかん　■
■夏みかん　みかん みかん箱 　ミカン　みかん　 'ミカン'　りんご酢　りんご　青りんご　リンゴ　バナナ　■
■ 　バナナ　みかん　りんご　ばなな　ばなな園　みかん缶詰　モンキーバナナ■
■　 ■
■■
■みかん■

　　＜結果＞　Ｂ列
■みかん りんご バナナ■
■夏みかん みかん みかん箱 りんご酢 りんご 青りんご バナナ■
■バナナ みかん りんご ばなな園 みかん缶詰 モンキーバナナ■
■■
■■
■みかん■

（※　■ は、外縁。■■ は、値無し。'ミカン' は、半角「ミカン」の意。）

↑こんな感じのサンプル、100,000行で試しながらマクロ書いてみました。
（仕様的には＃３さんのと似ているかと。）

目視でチェックできない文末のスペースとか、スペースの連続とか、全半角の誤入力とか、
ありがちなＮＧに（多少）対処していたりもしますが、
行数が多いようなので、なるべく軽く速く処理できるように書きました。

ただ、求める結果がこれで良いかどうかは質問者さんにしか解りませんね。
　１◆　[全角｜半角]　[大文字｜小文字]　（[かな｜カナ]）
　２◆　[部分一致｜完全一致]
　３◆　区切り文字（スペース）が連続した場合の処理
Excelの一般機能でも普通に確認を求めてくるような条件付けを
質問文なり補足欄なりで指定した方が
ニーズにピッタリあった回答が得られやすいと思いますよ。
この手の質問って、不調に終わること多いですけれど
勘を頼りに独自の解釈で答えをつけて、ニーズと違ってたり、
なんであれ汎用的に応えようとして
必要以上に煩雑だったり、難しすぎると毛嫌いされたり、それでも不足があったり、、、
もう少し対話的にできればいいのになぁと思ってしまいます。
できれば、提示された方法を一度は試してみて欲しいです。
数が多いと大変なのは解るのですけどね。
一応、何か補足をする場合の介けにでもなればと、以上書いてみました。



' ' ==================新規の標準モジュール==================
' ' ========================================================
Option Explicit
Option Compare Text
' ' ========================================================
Sub Re7810353L()
　　Const nTop As Long = 1
　　Dim mtxS
　　Dim mtxP
　　Dim nBtm As Long
　　Dim nYSize As Long
　　Dim i As Long

　　nBtm = Cells(Rows.Count, 1).End(xlUp).Row
　　nYSize = nBtm - nTop + 1

　　mtxS = Range("A" & nTop & ":A" & nBtm).Value

　　ReDim mtxP(1 To nYSize, 1 To 1)
　　For i = 1 To nYSize
　　　　mtxP(i, 1) = fLtdTxtUniqFilter(mtxS(i, 1))
　　Next i

　　Application.ScreenUpdating = False
　　With Range("B" & nTop & ":B" & nBtm)
　　　　.Value = Empty
　　　　.Value = mtxP
　　End With
End Sub
' ' --------------------------------------------------------
Function fLtdTxtUniqFilter(ByVal S As String, Optional ByVal D As String = " ") As String
　　Dim sPr As String
　　Dim nLn As Long
　　Dim nSP As Long
　　Dim nPP As Long
　　Dim nPL As Long

'　　If Len(D) <> 1 Then Exit Function
　　nLn = Len(S) + 2
　　sPr = String$(nLn, D)
　　S = D & S & D

　　nSP = 2&
　　nPP = 2&
　　Do
　　　　nPL = InStr(nSP, S, D) - nSP
　　　　If nPL > 0 Then
　　　　　　If InStrRev(sPr, Mid$(S, nSP - 1&, nPL + 2&), nPP) = 0 Then
　　　　　　　　Mid(sPr, nPP) = Mid$(S, nSP, nPL)
　　　　　　　　nPP = nPP + nPL + 1&
　　　　　　End If
　　　　End If
　　　　nSP = nSP + nPL + 1&
　　Loop While nSP < nLn

　　If nPP < 3& Then Exit Function
　　fLtdTxtUniqFilter = Mid$(sPr, 2, nPP - 3&)
End Function
' ' ========================================================

ＡＬＴ＋Ｆ１１を押す

現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
　dim a, myDic, x
　dim h As Range
　set myDic = createobject("Scripting.Dictionary")
　on error resume next
　range("B:B").clearcontents

　for each h in range("A1:A" & range("A65536").end(xlUp).row)
　　a = split(replace(h, "　", " "), " ")
　　for each x in a
　　　mydic.add x, ""
　　next
　　h.offset(0, 1) = join(mydic.keys, " ")
　　mydic.removeAll
　next

end sub

ファイルメニューから終了してエクセルに戻る
Ａ列に元データを配置、ＡＬＴ＋Ｆ８を押しマクロを実行して完成。

「区切り位置」と「統合」という一般機能を組み合わせた簡単な方法をご紹介します。

文章で説明すると長くてたいへんそうですが、実際はアッと言う間に終わると思います。

(1)
A 列と B 列の間に十分な数の列を挿入してください。具体的には、A 列に入力されている最大の単語数よりも多い列数を空けます。そうしておかないと、次の「区切り位置」を完了する際に、B 列のデータを上書きしてしまうとの警告が出ます。

(2)
A 列全体を選択した状態で、リボン「データ」の「区切り位置」ウィザードを起動。「カンマやタブなどの…」を指定し、「次へ」。「スペース」にチェックを入れ、「完了」。1 セルに入力されていた複数の単語が複数のセルに分割されます。

(3)
旧 B 列に対して(2)と同じ処理をします。

(4)
新しくできた A 列、B 列、C 列、…の右隣にそれぞれ 1 列ずつ挿入された状態にします。

(5)
列を挿入後の B1 セルに好きな数字を入力します。

(6)
(5)までに作成されている一覧の外にあるどこかのセル（添付図では A7）をクリックします。この位置に、次の「統合」による結果が入力されます。

(7)
リボン「データ」の「統合」ダイアログを起動。「統合元範囲」として「$A$1:$B$4」、「$C$1:$D$4」などを記入し、それぞれを「追加」ボタンで「統合元」一覧に加えていきます。この記入の作業はマウスのドラッグでできるのですが、6,000 行と量が多いなら、適当な行数の範囲をドラッグしておいて、行番号だけタイプして 6000 に書き換えるとラクでしょう。最後に「左端列」にチェックを入れて OK すれば、でき上がり。

回答No1です。

シート2のU1セルに入力する式はあまりにも力技といった感じですので、シート2でのK1セルへの入力する式を、K1セルを空にしてL1セルに入力しU1セルまでドラッグコピーします。

=IF(COUNTIF($A1:A1,A1)=1,TRIM(K1&" "&A1),K1)

シート2のU列を選択してコピーし、シート1のB1セルに貼り付けをすればよいでしょう。
マクロを使って処理するよりも計算に負担がかからないでしょう。

　毎回、コピー&ペーストやボタンのクリック等の手動損さを行わずとも、関数と作業シートを使用して全自動で行う事が出来る方法です。

　今仮に、A列に元データが入力されているシートがSheet1であり、Sheet2を作業シートとして使用するものとします。
　まず、Sheet2のA1セルに次の関数を入力して下さい。

=IF(INDEX(Sheet3!$A:$A,ROW())="",""," "&SUBSTITUTE(TRIM(SUBSTITUTE(INDEX(Sheet3!$A:$A,ROW()),"　"," "))," "," ")&" ")

　※「ROW()),」の直後にある"　"内の空白は全角の空白1文字、「)&」の直前にある" "内の空白は半角の空白2文字ですから、間違わないよう注意して下さい。
　次に、Sheet2のB1セルに次の関数を入力して下さい。

=IF(OR(A1="",A1=CHAR(160)),"",IF(ISNUMBER(FIND(" ",A1,2)),SUBSTITUTE(A1,LEFT(A1,FIND(" ",A1,2)),)&CHAR(1)&TRIM(LEFT(A1,FIND(" ",A1,2))),CHAR(160)))

　次に、Sheet2のB1セルをコピーして、「Sheet1のA列の1つのセル内に、存在している単語の"種類の"数」を2つ以上上回るのに十分な列数となるまで、Sheet2のB1よりも右にあるセル範囲に貼り付けて下さい。
　次に、Sheet2の1行目全体をコピーして、2行目以下に貼り付けて下さい。

　次に、Sheet1のB1セルに次の関数を入力して下さい。

=IF(INDEX($A:$A,ROW())="","",TRIM(SUBSTITUTE(INDEX('Sheet3 (2)'!1:1,MATCH(CHAR(160),'Sheet3 (2)'!1:1,0)-1),CHAR(1)," ")))

　次に、Sheet1のB1セルをコピーして、Sheet1のB2以下に貼り付けて下さい。

　これで、Sheet1のA列のセルに元データを入力するだけで、Sheet1のB列のセルに重複する単語を1個だけ残して削除した文字列が、自動的に表示されます。

こんばんは。

VBAの古いアルゴリズムですが、ユニーク抽出の解決方法があります。
関数の方法もあるのかもしれませんが、どのみち、配列を使うのでしたら、6000行では無理でしょうから、VBAの解決に軍配が上がるかもしれません。なお、食事前に即席で作ったものですので、バグが残っているかもしれません。（スペックとしては同じ環境です）

たぶん、スペースは全角でも半角でも、また、スペースが複数でも、処理出来るはずです。

標準モジュールに貼り付けてください。

'//
Sub UniqSelect()
　'ユニークなデータを抽出する
　Dim c As Variant
　Dim a As Variant
　Dim k As Variant
　Application.ScreenUpdating = False
　For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
　　a = Trim(c.Value)
　　If InStr(1, a, " ", 1) > 0 And a <> "" Then
　　　Do
　　　　a = Replace(a, Space(2), Space(1), , , vbTextCompare)
　　　Loop Until InStr(1, a, Space(2), 1) = 0
　　　a = Split(a, Space(1), , 1)
　　　k = UniqData(a)
　　　c.Offset(, 1).Value = Join(k, Space(1))
　　Else
　　　c.Offset(, 1).Value = a
　　End If
　　a = ""
　Next c
　Application.ScreenUpdating = True
End Sub

Function UniqData(myData As Variant)
Dim Ub As Long
Dim i As Long, j As Long
Dim k As Long, m As Long, o As Long
Dim S As Long
Dim Flg As Boolean
Dim a()
　 Ub = UBound(myData)
　 ReDim a(0 To Ub)
　For j = 0 To Ub
　　　a(0) = myData(0)
　　　Flg = True　'sentinel
　　　For m = 0 To S
　　　　 If a(m) = myData(j) Then
　　　　　　Flg = False
　　　　　　Exit For
　　　　 End If
　　　Next m
　　　If Flg = True Then
　　　　 S = S + 1
　　　　 a(S) = myData(j)
　　　End If
　　Next j
　　For o = 0 To Ub
　　　If a(o) = Empty Then
　　　　 Exit For
　　　End If
　　Next o
　　ReDim Preserve a(0 To o - 1)
　　UniqData = a
End Function

行数が6000とかなりのデータ数ですので複雑な式を使って作業すれば計算にも負担がかかります。

作業シートを別に用意して対応するのがよいでしょう。
ご質問のデータがシート1のA列にあるとします。単語の数が仮に10までに対応できる方法です。勿論それ以上でも可能です。
シート1のA列をコピーしてシート2のA1セルを選択して貼り付けます。
その後にシート2のA列を選択してから「データ」タブの「区切り位置」で「カンマやタブの区切り文字によって…」を選択し、「次へ」をクリック、「スペース」にチェックをして「次へ」「完了」と進みます。
A列に合った文字列がスペースごとに個々の列に表示されます。
シート2のK1セルには次の式を入力してT1セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(COUNTIF($A1:A1,A1)=1,A1,"")

重なりのない形で文字列が表示されます。
シート2のU1セルには次の式を入力して下方にドラッグコピーします。

=K1&" "&L1&" "&M1&" "&N1&" "&O1&" "&P1&" "&Q1&" "&R1&" "&S1&" "&T1

このデータをシート1のB列に貼り付けをすればよいでしょう。
あるいはシート1のB1セルには次の式を入力して下方にドラッグコピーすれば完成です。

=Sheet2!U1