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

Question

よろしくお願いいたします。
セル内にスペースで区切られた文字列（単語）があり、文字列の数は不確定です。
その文字列の中で重複する文字列があり、それらを1つにまとめたいという要望です。
セルの行数は約6000ほどあります。

例

A1セル：リンゴ リンゴ みかん
B1セル：リンゴ みかん
A2セル：みかん　バナナ みかん バナナ みかん
B2セル：みかん バナナ
・・・

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

Windows7　HomePremium
Office2010

tom04 · Accepted Answer

こんばんは！
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

cj_mover · Answer

こんにちは。お邪魔します。　　＜元データ　ダミーサンプル＞　Ａ列 ■みかん　りんご　バナナ　　りんご　みかん　■ ■夏みかん　みかんみかん箱　ミカン　みかん　 'ミカン'　りんご酢　りんご　青りんご　リンゴ　バナナ　■ ■ 　バナナ　みかん　りんご　ばなな　ばなな園　みかん缶詰　モンキーバナナ■ ■　 ■ ■■ ■みかん■ 　　＜結果＞　Ｂ列 ■みかんりんごバナナ■ ■夏みかんみかんみかん箱りんご酢りんご青りんごバナナ■ ■バナナみかんりんごばなな園みかん缶詰モンキーバナナ■ ■■ ■■ ■みかん■ （※　■ は、外縁。■■ は、値無し。'ミカン' は、半角「ミカン」の意。） ↑こんな感じのサンプル、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 ' ' ========================================================

keithin · Answer

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

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

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

MarcoRossiItaly · Answer

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

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

(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 すれば、でき上がり。

KURUMITO · Answer

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

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

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

kagakusuki · Answer

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

今仮に、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個だけ残して削除した文字列が、自動的に表示されます。

WindFaller · Answer

こんばんは。

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

KURUMITO · Answer

行数が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

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

こんばんは！

こんにちは。

ＡＬＴ＋Ｆ１１を押す

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

回答No1です。

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

こんばんは。

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

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

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