同一セル内での重複削除

質問

同一セル内での重複削除

今手元にとあるデータがあります。
そのデータは同一セル内に「○○株式会社／■■印刷／▼▼株式会社／○○株式会社」のように、スラッシュ区切りで会社名が入っています。
このデータから、重複している会社名を削除したいと考えています。上記の例ですと「○○株式会社」が重複していますので、これを削除し「○○株式会社／■■印刷／▼▼株式会社」としたいです。
データが大量にあるので、関数を使用するよりも、マクロを使用した方が時間的にも作業量的にも楽だと思うのですが、いまいちどうやって良いか分かりません。

要約しますと、同一セル内にある重複データを削除するマクロを作れるのか、作れるならばどのようなものか、ということを教えていただきたいと思います。
また、もし削除した際に「・・・・・／」と末尾がスラッシュになった場合、最後のスラッシュだけを削除する方法も教えていただければうれしいです。
ちなみに、会社名の順序に意味はありませんので、重複したデータの1つめを削除するのか、2つめを削除するのかは気にしていません。

どなたかお願いいたします。

回答No.3

cj_mover · ベストアンサー

お邪魔します。

ワークシート用を兼ねた関数です。
標準モジュールに貼り付けます。

シートからは、数式として、
　=myfFiltUniq(A1,"/")
のように書きます。
　もし、
　"ABC/abc/ＡＢＣ/ａｂｃ"を第一引数に渡して、"ABC"だけ（最左だけ）を返す場合は、
　=myfFiltUniq(A1,"/",1)
　とします。
　第三引数を省略（規定値は０）すると"ABC/abc/ＡＢＣ/ａｂｃ"が返ります。
（ＶＢＡでの扱いも殆ど同じですし、むしろ易しいはずです。）
（エラーを出そうと思って使うならバグが無いでもないですが対策は省きます。）

方法は色々あると思いますが、パフォーマンス云々は抜きにして、
用途に合った－Filter()関数の使い方－をメインにした、レス、です。
（使う機会がなかなか無い↑ので、、、ここぞとばかり（＾＾；）

Function myfFiltUniq(ByVal Source As String, Delimiter As String, _
　　　　Optional Compare As VbCompareMethod = vbBinaryCompare)
　　Dim vArr As Variant
　　Dim sTmp As String
　　vArr = Split(Source, Delimiter)
　　If UBound(vArr) < 1 Then
　　　　myfFiltUniq = Source
　　　　Exit Function
　　End If
　　Do
　　　　If vArr(0) = "" Then
　　　　　　vArr(0) = vbNullString
　　　　Else
　　　　　　sTmp = sTmp & Delimiter & vArr(0)
　　　　End If
　　　　　　vArr = Filter(vArr, vArr(0), False, Compare)
　　Loop While -1 < UBound(vArr)
　　myfFiltUniq = Mid$(sTmp, 2)
End Function

===============================================================================

お礼

ありがとうございました。

ほかにもお二方から御回答をいただきましたが、自分でも好みに改変しやすい、データに加工が必要ない、この2点でベストアンサーに選ばせていただきました。

回答No.4

cj_mover

こんにちは、レスをありがとうございます。
質問締切から時間が経っていますが、必要と考え、追加回答をさせて頂くことにしました。
　（#許されるなら回答の差し替えをお願いしたいのですが#）
私が書いた”回答 No.3 ”に不具合があった為、です。
恐れ入りますが、以下の説明をお読みいただいた上で、
”回答 No.3 ”提示の関数を差し替えてくださいますようお願いします。
ご迷惑をお掛けしてすみません。

＜不具合の内容＞
｜”回答 No.3 ”提示の関数は、部分的な一致を重複と解釈して削除してしまうという問題がありました。
｜　Ex.）
｜　　”△△HD／△△／△△東日本／△△西日本”
｜　　→”△△HD／△△”
｜　　”□□株式会社／平成□□株式会社／昭和□□株式会社／南□□株式会社／新□□株式会社”
｜　　→”□□株式会社”
｜以上のように意図しない結果を返してしまう場合があります。
細かな仕様にばかり拘って基本的な確認を怠ってしまった私のミス（ポカ）です。ごめんなさいm(__)m
＜検討すべき点＞
｜本来は、完全な一致のみ重複削除するのが、当然ながら基本です。
｜その上で、或いは要求に応える形での仕様として、
｜　Ex.）「前方一致するものを重複削除」
｜　　”（株）○○／（株）○○・事業部／（株）○○・総務部”
｜　　→”（株）○○”
｜のような抽出が出来るように、（ソート機能を追加した上で）
｜　［一致（＝T）｜前方一致（T*）｜後方一致（*T）］｜前方一致（*T*）］
｜の中から選べる機能を持たせる場合もあるかもしれません。
｜しかしながら、今回の案件についてはそもそも、そこまでの必要はないようです。
現実でのやりとりなら双方向でニーズの確認と提案が容易にできるのですが、BBSを甘く見ていたかもしれません。
＜手当て＞
｜以上のような理由で関数の作り直しに取り掛かかり、拙いながらも２０パターン程実際に書いてみました。
｜記述の簡潔さと処理能力とで中庸のバランスを取った関数（という意図で書いたもの）を再提示します。
｜使い方（機能）は前提示と変わりありませんが、
｜部分一致で重複削除されないように正しました（多少の改良を加えたつもりです）。
色々な意味で勉強する（反省する）よい機会を与えてくださった質問者様に感謝しております。ありがとうございました。
＜数式での使用例＞
｜Ex.1)
｜ A1: "ABC／abc／ABC／／ａｂｃ／ＡＢＣ／アカサ／アカサ／abcD／Zabc／アカサ／"
｜　=myfFU(A1,"／")
｜　　→　"ABC／abc／ａｂｃ／ＡＢＣ／アカサ／アカサ／abcD／Zabc"
｜　=myfFU(A1,"／",1)
｜　　→　"ABC／アカサ／abcD／Zabc"
｜　※↑この場合、一致するものの中で最初（最も左）にあるものが抽出されます※
｜Ex.2) 第三引数に依らず
｜ A1: "／"　（または、A1: 空白セル）
｜　　→　""
｜Ex.3) 第三引数に依らず
｜ A1: "ABC"　
｜　　→　"ABC"

＜関数の再提示＞
' ' ==========================注意事項==========================
Excel2000/2003 にて動作確認しました。
標準モジュールに下記のコードをコピペしてください。
VBAの記述の冒頭部分は
モジュールの先頭にある（上に何も書かれていない）ことが必要です。
また、Enum　から　End Enum　までの部分は一箇所にしか書けませんので
重複しないようにしてください。
混乱を避ける意味で関数名を変えています。
既にシート上でお使いの場合は置換機能を使って関数名を一括置換してください。
' ' ===========================ここから===========================
Option Explicit
Enum myCompareMethod
　　　　myBinaryCompare ' = 0
　　　　myTextCompare ' = 1
End Enum
' ' ============================================================
Function myfFU(ByVal 文字列 As String, ByVal 区切り文字 As String, _
　　　　　　　　Optional ByVal TextCompare As myCompareMethod = myBinaryCompare) As String
If TextCompare Then TextCompare = myTextCompare
　　　　Dim A As Variant
　　　　Dim S As String
　　　　Dim N As Long
　　　　If 文字列 = "" Then Exit Function
　　　　A = Split(文字列, 区切り文字) ' LBound 0
　　　　A = Application.Text(A, """" & 区切り文字 & """@""" & 区切り文字 & """") ' LBound 1
　　　　A = Filter(A, String$(2&, 区切り文字), False, vbBinaryCompare) ' LBound 0
　　　　S = String$(Len(文字列) + 2&, 区切り文字)
　　　　N = 1&
　　　　Do While UBound(A) > -1&
　　　　　　　　Mid(S, N) = A(0)
　　　　　　　　N = InStr(N + 1&, S, 区切り文字)
　　　　　　　　A = Filter(A, A(0), False, TextCompare)
　　　　Loop
　　　　If N > 1& Then myfFU = Mid$(S, 2&, N - 2&)
　　　　Erase A
End Function
' ' ===========================ここまで===========================

回答No.2

nag0720

重複データを削除する関数を作ってみました。

Function 重複削除(S As String) As String
Dim i As Integer
Dim j As Integer
Dim S1() As String
Dim S2 As String
Dim Exist As Boolean

S1() = Split(S, "／")
S2 = S1(0)
For i = 1 To UBound(S1)
Exist = False
For j = 0 To i - 1
If S1(i) = S1(j) Then
Exist = True
Exit For
End If
Next
If Not Exist Then S2 = S2 & "／" & S1(i)
Next
重複削除 = S2
End Function

あとは、対象のセルでこの関数を適用してください。

Sub test()
Cells(1, 1) = "○○株式会社／■■印刷／▼▼株式会社／○○株式会社"
Cells(1, 2) = 重複削除(Cells(1, 1))
MsgBox Cells(1, 2)
End Sub

お礼

ありがとうございました。

御回答いただいた方法もよかったのですが、No.3の方をベストアンサーとさせていただきました。
今後も、何かあった際は、ご指導、ご鞭撻のほどよろしくお願い申し上げます。

回答No.1

tom04

こんばんは！
参考になるかどうか判りませんが・・・

無理やりって感じの方法です。
元データがSheet1にあるとします。
元データが変わってはまずいと思いますので、Sheet1すべてをSheet2にコピー＆ペーストして
Sheet2上（別にSheet2でなくても構いません）で試してみてください。

当方使用のExcel2003の場合です。
貼り付けがデータがSheet2のA列にデータがあるとします。
A列を範囲指定　→　データ　→　区切り位置　→　「カンマやタブなどの・・・」を選択　
→　次へ　→　「その他」にチェックを入れ「/」を入力　→　次へ　→　完了
これで「/」なしで列方向の各セルに区切られますので、
↓のコードをSheet2のシート見出し上で右クリック　→　コードの表示　を選択し
コピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim i, j As Long
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To ActiveSheet.UsedRange.Columns.Count
If WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, j)), Cells(i, j)) > 1 Then
Cells(i, j).Delete (xlToLeft)
End If
Next j
Next i
Dim k, l As Long
Dim str As String
For k = 1 To Cells(Rows.Count, 1).End(xlUp).Row
For l = 1 To Cells(k, Columns.Count).End(xlToLeft).Column
str = str & "/" & Cells(k, l)
Cells(k, l).Clear
Next l
Cells(k, 1) = WorksheetFunction.Replace(str, 1, 1, "")
str = ""
Next k
End Sub

以上、参考になれば良いのですが
他に良い方法があれば読み流してくださいね。m(__)m

お礼

ありがとうございました。

御回答いただいた方法もよかったのですが、No.3の方をベストアンサーとさせていただきました。
今後も、何かあった際は、ご指導、ご鞭撻のほどよろしくお願い申し上げます。