excel 文字列の重複していない部分を抽出したい

Question

色々探してみたのですが、わからず大変困っています。宜しくお願い致します。

やりたいこと：下記のデータから、共通する部分を除外して特定セルに貼付けたい。

＜補足説明＞
共通部分が１ヵ所の物と、２か所の物がありますので、出来れば両方抽出したいですが、もし２か所あると不可な場合は、共通部分１ヵ所のみの抽出でお願い致します。
※共通部分は最大２か所迄で、位置はランダムです。
※データ数は１～３０００です。
※商品名の列はH列、抽出した文字列はV列に貼り付けます。

説明文も入れてくださると大変助かります。

【元データ】

セルH2：ボールペン　あいう
セルH3：バッグA ブラック abc
セルH4：バッグA オレンジ abc
セルH5：バッグA レッド abc
セルH6：シャツB ブラック アイウ S
セルH7：シャツB ブラック アイウ M
セルH8：シャツB ブラック アイウ L
セルH9：シャツB ブルー アイウ S
セルH10：シャツB ブルー アイウ M
セルH11：シャツB ブルー アイウ L

【下記のようにしたい】　※V列の文字列は半角スペースで区切りたいです。

セルH2：ボールペン　あいう　　　　　セルV2：
セルH3：バッグA  abc　　　　　　　　　セルV3：商品選択 ブラック オレンジ レッド
　　　　　　　　　　　　　　　　　　　　　　　　　　　　※もしくは、ブラック オレンジ レッド
セルH4：                                     セルV4：
セルH5：　　　　　　　　　　　　　　　　　セルV5：
セルH6：シャツB  アイウ 　　　　　　　セルV6：商品選択 ブラック ブルー改行改行商品選択1 S M L
　　　　　　　　　　　　　　　　　　　　　　　　　　　　※もしくは、ブラック ブルー改行改行S M L
セルH7：　　　　　　　　　　　　　　　　　セルV7：
セルH8：　　　　　　　　　　　　　　　　　セルV8：
セルH9：　　　　　　　　　　　　　　　　　セルV9：
セルH10：　　　　　　　　　　　　　　　　 セルV10：
セルH11：　　　　　　　　　　　　　　　　 セルV11：

※最終的には、下記のようにしたいです。
セルH2：ボールペン　あいう　　　　　セルV2：
セルH3：バッグA  abc　　　　　　　　　セルV3：商品選択 ブラック オレンジ レッド
セルH4：シャツB  アイウ 　　　　　　　セルV4：商品選択 ブラック ブルー改行改行商品選択1 S M L

tom04 · Accepted Answer

No.3です。

補足を読みました。
最初の質問とはサンプルがかなり異なるようですが・・・
いずれにしてもSheet1のH列データは最後が「色」になっているという前提です。
尚、色の前のスペースは半角でも全角でも対応できるようにしています。
そして、Sheet3を作業用のSheetとして使用していますので、
最低3Sheetあり、Sheet3は全く使用していないSheetにしてください。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample2()
    Dim i As Long, k As Long, str As String, lastRow As Long, c As Range
    Dim wS2 As Worksheet, wS3 As Worksheet
    Set wS2 = Worksheets("Sheet2")
    Set wS3 = Worksheets("Sheet3")
    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
    lastRow = wS2.Cells(Rows.Count, "H").End(xlUp).Row
        If lastRow > 1 Then
            Range(wS2.Cells(2, "H"), wS2.Cells(lastRow, "H")).ClearContents
            Range(wS2.Cells(2, "V"), wS2.Cells(lastRow, "V")).ClearContents
        End If
    .Range("H:H").Replace what:="　", replacement:=" ", lookat:=xlPart
    For i = 2 To .Cells(Rows.Count, "H").End(xlUp).Row
        If InStr(.Cells(i, "H"), " ") > 0 Then
            str = Left(.Cells(i, "H"), InStrRev(.Cells(i, "H"), " ") - 1)
                Set c = wS3.Range("A:A").Find(what:=str, LookIn:=xlValues, lookat:=xlWhole)
                    If c Is Nothing Then
                        wS3.Cells(Rows.Count, "A").End(xlUp).Offset(1) = str
                    End If
        End If
    Next i
    For k = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To .Cells(Rows.Count, "H").End(xlUp).Row
        If InStr(.Cells(i, "H"), wS3.Cells(k, "A")) > 0 Then
        If wS3.Cells(k, "B") = "" Then
            wS3.Cells(k, "B") = Trim(Replace(.Cells(i, "H"), wS3.Cells(k, "A"), ""))
        Else
            wS3.Cells(k, "B") = wS3.Cells(k, "B") & " " & Trim(Replace(.Cells(i, "H"), wS3.Cells(k, "A"), ""))
         End If
        End If
    Next i
    Next k
    End With
    lastRow = wS3.Cells(Rows.Count, "A").End(xlUp).Row
        Range(wS3.Cells(2, "A"), wS3.Cells(lastRow, "A")).Copy wS2.Range("H2")
        Range(wS3.Cells(2, "B"), wS3.Cells(lastRow, "B")).Copy wS2.Range("V2")
    wS2.Columns.AutoFit
    wS3.Cells.Clear
    Application.ScreenUpdating = True
End Sub

今度はどうでしょうか？m(_ _)m

tom04 · Answer

こんばんは！
規則性がなかなか見つからないのですが・・・

H列のデータは半角スペースで区切られていて、
商品　→　色　→　商品名？　→　サイズ　の順になっているという前提です。
（H2のように全角スペースの場合は、一つの商品と判断しています）

元データがSheet1にあり、Sheet2に表示するようにしてみました。
VBAになってしまいますが、一例です。

Alt+F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面（カーソルが点滅しているところ）に
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください）
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1()   'この行から
    Dim i As Long, c As Range, r As Range
    Dim wS1 As Worksheet, wS2 As Worksheet, myArray
    Set wS1 = Worksheets("Sheet1")
    Set wS2 = Worksheets("Sheet2")
    Application.ScreenUpdating = False
    wS2.Range("A:C").ClearContents
    For i = 2 To wS1.Cells(Rows.Count, "H").End(xlUp).Row
    myArray = Split(wS1.Cells(i, "H"), " ")
    Select Case UBound(myArray)
        Case 0
            Set c = wS2.Range("A:A").Find(what:=myArray(0), LookIn:=xlValues, lookat:=xlWhole)
                If c Is Nothing Then
                    wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1) = myArray(0)
                End If
        Case 1
            Set c = wS2.Range("A:A").Find(what:=myArray(0), LookIn:=xlValues, lookat:=xlWhole)
                If c Is Nothing Then
                    With wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
                        .Value = myArray(0)
                        .Offset(, 1) = myArray(1)
                    End With
                Else
                    Set r = wS2.Range("B:B").Find(what:=myArray(1), LookIn:=xlValues, lookat:=xlWhole)
                        If r Is Nothing Then
                            c.Offset(, 1) = myArray(1)
                        Else
                            c.Offset(, 1) = c.Offset(, 1) & " " & myArray(1)
                        End If
                End If
        Case 2
            Set c = wS2.Range("A:A").Find(what:=myArray(0) & " " & myArray(2), LookIn:=xlValues, lookat:=xlWhole)
                If c Is Nothing Then
                    With wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
                        .Value = myArray(0) & " " & myArray(2)
                        .Offset(, 1) = myArray(1)
                    End With
                Else
                    If InStr(c.Offset(, 1), myArray(1)) > 0 Then
                        c.Offset(, 1) = myArray(1)
                    Else
                        c.Offset(, 1) = c.Offset(, 1) & " " & myArray(1)
                    End If
                End If
        Case Else
            Set c = wS2.Range("A:A").Find(what:=myArray(0) & " " & myArray(2), LookIn:=xlValues, lookat:=xlWhole)
                If c Is Nothing Then
                    With wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
                        .Value = myArray(0) & " " & myArray(2)
                        .Offset(, 1) = myArray(1)
                        .Offset(, 2) = myArray(3)
                    End With
                Else
                    If InStr(c.Offset(, 1), myArray(1)) = 0 Then
                        c.Offset(, 1) = c.Offset(, 1) & " " & myArray(1)
                    End If
                    If InStr(c.Offset(, 2), myArray(3)) = 0 Then
                        c.Offset(, 2) = c.Offset(, 2) & " " & myArray(3)
                    End If
                End If
        End Select
    Next i
    For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
        If wS2.Cells(i, "C") <> "" Then
            wS2.Cells(i, "B") = wS2.Cells(i, "B") & vbCrLf & wS2.Cells(i, "C")
        End If
    Next i
    wS2.Range("C:C").Clear
    wS2.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub 'この行まで

※　Sheet名がある場合はコード内の「Sheet1」・「Sheet2」の部分を実際のSheet名に変更してください。
※　サンプル数が少ないので、ご希望通りの動きになるかどうか判りません。m(_ _)m

bunjii · Answer

>※共通部分は最大２か所迄で、位置はランダムです。
1つのセルに複数の要素があるので分類要素を区分けする必要があります。
要素の境界に特定の文字が有るときは区切り記号として切り分けられます。
提示の様子では区切り記号として空白文字が使えます。
処理結果はH列、I列、J列、K列の最大4項目に分けられます。
大分類はH列で良いと思いますが、中風類の位置が不揃いようですから手作業の前処理が必要になります。

>※商品名の列はH列、抽出した文字列はV列に貼り付けます。
処理後の情報を1つのセルに纏めると次の段階で応用するときにまた面倒な処理になるでしょう。
文字列を切り出して位置を入れ替える処理はお勧めできません。

>※最終的には、下記のようにしたいです。
細かく分けた品目を大きな括りにまとめるのはどのような意味があるのか疑問です。
在庫管理や売上管理等に使う場合は細かく分けた品目毎に数量を把握して集計で纏めれば良いので品目を大きな括りにすることは逆効果のように感じます。

希望の処理はできないことではありませんが工夫しないと無駄な労力が掛かりそうです。

aokii · Answer

規則性がないので無理です。

excel 文字列の重複していない部分を抽出したい

No.3です。

こんばんは！

>※共通部分は最大２か所迄で、位置はランダムです。

規則性がないので無理です。

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

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

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

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