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

質問

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

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

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

回答No.4

tom04 · ベストアンサー

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

お礼

どうもありがとうございます。
最後に色の選択肢を付けているデータは、うまく行きました。
選択肢の無いデータも混在しているのですが、それは手作業で除いてからマクロを実行しようと思います。
おかげで随分楽になります。
大変助かりました。どうもありがとうございました。

回答No.3

tom04

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

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

お礼

プログラムを組んで頂きまして大変感謝しております。

早速確認してみたのですが、誠に残念ながら、思った結果にはなりませんでした。
質問の仕方が悪かったようで大変申し訳ございません。文字列の例が悪かったようですので、下記に実際のデータの１例を用い、やりたい事をもう一度記載してみました。
そもそも出来ないのかもしれないのですが、全部手作業の現状より少しでも簡略化したく相談させていただいた次第です。
宜しくお願い致します。

下記１例ですが、「[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 」が共通の部分、それ以外は１行ごとに違う値となっており、共通部分の文字列とそれ以外の文字列に分けて表示したいのです。共通部分はsheet2の同じセルに、それ以外の部分はsheet2のV列の同じ行に表示(この例ですとH2～H8迄の共通部分以外の文字列をV2にまとめて表示※半角スペース区切り)する方法はありますか。
また、共通部分以外の文字列は、全部の行に表示するのではなく、最初の行のみに表示（この例ですとV2にのみ表示）し、他の行は削除したいです。削除が難しいようなら、H3～H8のデータを空白にしてもOKです。

※この例では「それ以外の文字列」は最後尾にありますが、いつも最後尾とは限りません。また、ご指摘のようにスペースも半角・全角混在しており、2つ以上スペースが連続する場合やスペース自体がないデータもあるかもしれません。ですが、スペースは全て半角スペースに置換する事は可能ですので、スペースは半角のみで連続して2つ以上存在する事はない、としていただいて大丈夫です。ただし、[PEE CLU]のように分けない部分にもスペースが含まれることはあります。
※選択肢は必ずあるわけではなく、選択肢のないデータも混在しています。

＜元データ＞（sheet1）
セルH2:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 ネイビー
セルH3:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 ワイン
セルH4:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 ダークグリーン
セルH5:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 ピンク
セルH6:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 オレンジ
セルH7:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 ダークブラウン
セルH8:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工 ブラック
セルH9：ALICE【アリス】ショルダーバッグ ブラック　※選択肢の無いデータ
セルH10：【SALE】[DEL SSE]≪クラブトート≫A4サイズトート ブロンズ
セルH11：【SALE】[DEL SSE]≪クラブトート≫A4サイズトート ワイン
セルH12：【SALE】[DEL SSE]≪クラブトート≫A4サイズトート オレンジ

＜マクロ実行後データ＞(sheet2)
セルH2:[PEE CLU]≪ディリーリュック/≫2WAYリュックサック★撥水加工
セルH3:ALICE【アリス】ショルダーバッグ ブラック　※選択肢が無い為、ブラックを含む全文字列
セルH4：【SALE】[DEL SSE]≪クラブトート≫A4サイズトート

セルV2:ネイビー ワイン ダークグリーン ピンク オレンジ ダークブラウン ブラック
セルV3：空白　※選択肢が無い為
セルV4：ブロンズ ワイン オレンジ
※H3行～H8行・H11行～H12行迄は、削除。削除が難しい場合は、H3～H8およびH11～H12のセルの値を空白セルにする。
※この例では共通部分以外の文字列は１つしかありませんが、２個の場合もあります。

回答No.2

bunjii

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

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

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

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

お礼

回答ありがとうございます。

>処理結果はH列、I列、J列、K列の最大4項目に分けられます。

すみません。簡略化して記載しましたので、文字列は最大４項目とは限りません。それより多い場合もあります。

>処理後の情報を1つのセルに纏めると次の段階で応用するときにまた面倒な処理になるでしょう。

「商品選択 ブラック ブルー改行改行商品選択1 S M L」　の場合

　次の処理は特にありません。

「ブラック ブルー改行改行S M L」の場合

　「商品選択 ブラック ブルー改行改行商品選択1 S M L」への変換が必要です。

>細かく分けた品目を大きな括りにまとめるのはどのような意味があるのか疑問です。

質問の仕方が悪かったようで、申し訳ございません。商品登録の際にどうしても必要な作業となります。
CSVファイルにオプション設定を、V列のデータ形式で指定すると、同様の商品の色違いやサイズ違いの場合は、商品選択肢のある１ページのみが自動作成されますが、オプションを指定しないと、選択肢の数だけ複数ページ（商品選択肢のないページ）が作成されてしまいます。

難しそうですか？もうちょっとだけ募集させてください。全部自動は無理でも、一部自動でも助かります。最終的に欲しいと指定したものは、別シートに作成で構いません。

回答No.1

aokii

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

お礼

回答ありがとうございます。
無理なんですね。
全部、手作業でやるのは大変なので、こうすると全部手作業よりは簡単に出来る、というような事がありましたら、教えていただけるとありがたいです。
もう少し、募集してみます。