A列に"日本"という文字列が含まれていば、カラー別に分ける処理をしたいです。

A列に"日本"という文字列が含まれていば、カラー別に分ける処理をしたいです。サイズは必ずS～XLまであります。
（C列のカラーは半角スペースで繋がっております。宜しくお願い致します。

）

国 サイズ カラー
------------------------------------------------
中国 S 白 赤
中国 M 白 赤
中国 L 白 赤
中国 XL 白 赤
日本 S 黒 青
日本 M 黒 青
日本 L 黒 青
日本 XL 黒 青

マクロを実行すると・・・A列"日本"という文字列が含まれていば、カラー別に分ける
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

国 サイズ カラー
------------------------------------------------
中国 S 白 赤
中国 M 白 赤
中国 L 白 赤
中国 XL 白 赤
日本 S 黒
日本 M 黒
日本 L 黒
日本 XL 黒
日本 S 黒
日本 M 黒
日本 L 黒
日本 XL 黒
日本 S 青
日本 M 青
日本 L 青
日本 XL 青

宜しくお願いします。

質問者からの補足コメント

• 申し訳ないです、実行結果を下記に修正します。
  
  
  国 サイズ カラー
  ------------------------------------------------
  中国 S 白 赤
  中国 M 白 赤
  中国 L 白 赤
  中国 XL 白 赤
  日本 S 黒
  日本 M 黒
  日本 L 黒
  日本 XL 黒
  日本 S 青
  日本 M 青
  日本 L 青
  日本 XL 青

    補足日時：2018/11/12 15:04

No.1 回答者： めぐみん_ 回答日時： 2018/11/12 14:38

実行前後で”青”は４つなのはわかりますが、”黒”が８つに増えるのはどうしてでしょう？

この回答へのお礼

ご指摘頂きありがとうございます。実行後、”黒”４つの間違いでした。申し訳ないです。

お礼日時：2018/11/12 15:05

No.2 回答者： めぐみん_ 回答日時： 2018/11/12 15:33

No.1です。

確認なのですがB列やC列の並び順は提示しているようにしたいのですよね？
そうなるとうちのExcel（MicrosoftOffice）は古いままなので、Excel2007以降に追加された『Sortオブジェクト』が使えないのです。
⇒すなわちコードを書いても動作検証できない。
正しく書けるかもわからないですし。

やっぱりスッキリと処理をされたいでしょうから、ここは2007以降をお持ちの方の回答を待つしかなさそうです。申し訳ないです。

あとちょっと疑問に感じました事でC列は必ず２色存在するのかな？と、前回の数量って今回は不要なのかな？ですかね。

この回答へのお礼

ご質問頂きありがとうございます。
C列は必ず２色と限らず３色以上存在する時もあります。
数量は不要です。
B列やC列の並び順は提示していなくても大丈夫です。
宜しくお願い致します。

お礼日時：2018/11/12 15:45

No.3 ベストアンサー 回答者： めぐみん_ 回答日時： 2018/11/12 17:31

No.2です。

私の方で出来るのはこれ位ですかね。

Sub megu_3()
Dim i As Long
Dim v

Application.ScreenUpdating = False

With ActiveSheet 'アクティブなシート
For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If .Cells(i, 1).Value = "日本" Then
v = Split(.Cells(i, 3).Value, " ")
If UBound(v) > 0 Then
.Range(i + 1 & ":" & i + UBound(v)).Insert
.Range("A" & i).Resize(, 2).Copy .Range("A" & i + 1).Resize(UBound(v))
.Range("C" & i).Resize(UBound(v) + 1).Value = Application.Transpose(v)
End If
End If
Next
End With

Application.ScreenUpdating = True
End Sub

－－－

画像右が実行前、左が実行後の様子です。

No.4 回答者： googoo900 回答日時： 2018/11/12 20:28

エクセルの並べ替え機能でできます。

◆手順
１．データがあるセルを選択
２．メニュー　→　データ　→　並べ替え
３．最優先されるキー『列A』
４．『レベルの追加』
５．次に優先されるキー『列C』
６．『OK』をクリック

もし思い通りにならなかったら、CTRL＋"Z"で戻せます。
手順１で全データを選択することでうまくいく場合があります。

No.5 回答者： tom04 回答日時： 2018/11/12 21:14

こんばんは！

一例です。
元データはSheet1にあり、Sheet2に表示するようにしてみました。
標準モジュールにしてください。

Sub Sample1()
　Dim myDic As Object
　Dim i As Long, k As Long, lastRow As Long
　Dim myStr As String, wS As Worksheet
　Dim myKey, myR, myAry
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set wS = Worksheets("Sheet2")
　　　wS.Range("A:C").ClearContents
　　　　With Worksheets("Sheet1")
　　　　　wS.Range("A1:C1").Value = .Range("A1:C1").Value
　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　myR = Range(.Cells(2, "A"), .Cells(lastRow, "C"))
　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　If myR(i, 1) = "日本" Then
　　　　　　　　　myAry = Split(myR(i, 3), " ")
　　　　　　　　　　For k = 0 To UBound(myAry)
　　　　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myAry(k)
　　　　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　　　　myDic.Add myStr, ""
　　　　　　　　　　　　End If
　　　　　　　　　　Next k
　　　　　　　　Else
　　　　　　　　　myStr = myR(i, 1) & "_" & myR(i, 2) & "_" & myR(i, 3)
　　　　　　　　　　If Not myDic.exists(myStr) Then
　　　　　　　　　　　myDic.Add myStr, ""
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　Next i
　　　　End With
　　　myKey = myDic.keys
　　　　myR = Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "C"))
　　　　　For i = 0 To UBound(myKey)
　　　　　　myAry = Split(myKey(i), "_")
　　　　　　　myR(i + 1, 1) = myAry(0)
　　　　　　　myR(i + 1, 2) = myAry(1)
　　　　　　　myR(i + 1, 3) = myAry(2)
　　　　　Next i
　　　　Range(wS.Cells(2, "A"), wS.Cells(UBound(myKey) + 2, "C")) = myR
　　　　　Set myDic = Nothing
　　　　　MsgBox "完了"
End Sub

※　B列のS～XLの順がお望み通りでないかもしれませんが、
上記マクロを実行すると↓の画像のような感じになります。

※　コードは長いですが、数万行のデータがあっても
数秒で終わるコードにしています。m(_ _)m