スペースで別れたセル内の数値を若い順に並び替える

質問

A１＝ b62 3d 6e b7f
A2 = s6c 2d 6e s7f
とA列内の各セルに、2桁ないし３桁の文字列（左はsかbもしくはブランク、 真ん中は1から7までの整数、右はアルファベットaからfまで）が各4つ～6つ程あります。これを以下の規則に従って、セル内で並び替えることはできますか？マクロだと助かります。
規則は
(1)真ん中の数字が若い順に並び替え
(2)真ん中の数字が同じものが複数ある場合は右のアルファベットが若い順に並び替え
(3)真ん中と右の数字が同じものが複数ある場合はｂ、ブランク、ｓの順に並び替え。
つまり
A64= s7b b7b 7b 7c
だったら
A64＝b7b 7b s7b 7c
このように並び替えられるようにしたいのですが、可能でしょうか。

回答No.1

tom04 · ベストアンサー

こんばんは！
一例です。

元データはSheet1のA1セル以降にあり、B列に表示するようにしてみました。
Sheet2を作業用のSheetとして使用していますので、
Sheet2はまっさらな状態にしておいてマクロを実行してみてください。

尚、
（1）半角スペースで区切られている文字列は2文字もしくは3文字として、必ず1文字目、または2文字目に数値になっている

（2）3文字の場合1文字目は「ｂ」か「ｓ」のどちらかである

という前提です。

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

Sub 並び替え()
Dim i As Long, j As Long, k As Long, cnt As Long, buf As String
Dim wS1 As Worksheet, wS2 As Worksheet, myArray
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
If InStr(StrConv(wS1.Cells(i, "A"), vbNarrow), " ") > 0 Then
myArray = Split(StrConv(wS1.Cells(i, "A"), vbNarrow), " ")
For k = 0 To UBound(myArray)
cnt = cnt + 1
wS2.Cells(cnt, "A") = myArray(k)
If Len(myArray(k)) < 3 Then
wS2.Cells(cnt, "A") = "h" & myArray(k) '←空白を「h」に置き換え
End If
For j = 1 To 3
wS2.Cells(cnt, j + 1) = Mid(wS2.Cells(cnt, "A"), j, 1)
Next j
Next k
wS2.Range("A1").CurrentRegion.Sort key1:=wS2.Range("C1"), order1:=xlAscending, Header:=xlNo, _
key2:=wS2.Range("D1"), order1:=xlAscending, Header:=xlNo, _
key3:=wS2.Range("B1"), order1:=xlAscending, Header:=xlNo
For cnt = 1 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
buf = buf & Trim(Replace(wS2.Cells(cnt, "A"), "h", " ")) & " "
Next cnt
wS1.Cells(i, "B") = Left(buf, Len(buf) - 1)
wS2.Range("A:D").Clear
cnt = 0
buf = ""
End If
Next i
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

いつも本当にありがとうございますm(__)m
とりあえず一日かけて解読していこうと思います１