同一セル内での重複削除

Question

同一セル内での重複削除

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

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

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

cj_mover · Accepted Answer

お邪魔します。

ワークシート用を兼ねた関数です。
標準モジュールに貼り付けます。

シートからは、数式として、
　=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


===============================================================================

cj_mover · Answer

こんにちは、レスをありがとうございます。
質問締切から時間が経っていますが、必要と考え、追加回答をさせて頂くことにしました。
　（#許されるなら回答の差し替えをお願いしたいのですが#）
私が書いた”回答 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
' ' ===========================ここまで===========================

nag0720 · Answer

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

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

tom04 · Answer

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

無理やりって感じの方法です。
元データが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

同一セル内での重複削除

こんにちは、レスをありがとうございます。

お邪魔します。

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

こんばんは！

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

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

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

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

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

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