編集履歴

回答編集履歴

サンプルコードの修正

2015/11/05 11:58

投稿

スコア5936

test CHANGED Viewed

@@ -255,3 +255,307 @@
 End Sub
 ```
+---
+＜コード修正：2015/11/05 22:5６＞
+お待たせ致しました。コードを修正致しましたので、再度ご確認頂けますか？
+```
+Option Explicit
+'------------------------------------------------------------------------------
+'  正規表現による文字列置換
+'------------------------------------------------------------------------------
+Function RegReplace(strTarget As String, _
+                    strPattern As String, _
+                    strReplaced As String, _
+                    Optional blnGlobal As Boolean = False) As String
+  Dim objRex As Object
+  Set objRex = CreateObject("VBScript.RegExp")
+  objRex.Pattern = strPattern
+  objRex.Global = blnGlobal
+  RegReplace = objRex.Replace(strTarget, strReplaced)
+  Set objRex = Nothing
+End Function
+'------------------------------------------------------------------------------
+'  正規表現によるマッチング
+'------------------------------------------------------------------------------
+Function RegMatch(strTarget As String, _
+                  strPattern As String) As Boolean
+  Dim objRex As Object
+  Set objRex = CreateObject("VBScript.RegExp")
+  objRex.Pattern = strPattern
+  RegMatch = objRex.Test(strTarget)
+  Set objRex = Nothing
+End Function
+'------------------------------------------------------------------------------
+'  対象データの並べ替え
+'------------------------------------------------------------------------------
+Sub CustomSort()
+  Dim xlBook As Workbook
+  Dim xlSheet As Worksheet
+  Dim vntTarget As Variant
+  Dim strOrder() As String
+  Dim o As Long
+  Dim i As Long
+  Dim j As Long
+  Dim k As Long
+  Dim l As Long
+  Set xlBook = ThisWorkbook
+  Set xlSheet = xlBook.Worksheets("Sheet1")
+  ' 文字列部の並び順の指定
+  i = 1
+  ReDim Preserve strOrder(i)
+  strOrder(i) = "Z"
+  '
+  i = i + 1
+  ReDim Preserve strOrder(i)
+  strOrder(i) = "WX"
+  '
+  i = i + 1
+  ReDim Preserve strOrder(i)
+  strOrder(i) = "ST"
+  '
+  i = i + 1
+  ReDim Preserve strOrder(i)
+  strOrder(i) = "UV"
+  '
+  i = i + 1
+  ReDim Preserve strOrder(i)
+  strOrder(i) = "Y"
+  ' ソート結果出力先の列番号
+  o = 1
+  With xlSheet
+    ' ソート対象の領域を配列に読み込み
+    vntTarget = .Range(.Cells(1, 1), .Cells(Rows.Count, 2).End(xlUp))
+    ' アルファベット部のソート順にブロック化した際の開始行と最終行の行番号を初期化
+    k = 1
+    l = 1
+    ' 文字列部の並び順に数値部の昇順にソートする
+    For i = 1 To 5
+      ' 文字列部の並び順にブロック化
+      For j = 1 To UBound(vntTarget, 1)
+        If RegMatch(CStr(vntTarget(j, 1)), "^" & strOrder(i) & "[0-9]") Then
+          .Cells(l, o).Value = CStr(vntTarget(j, 1))
+          .Cells(l, o + 1).Value = CStr(vntTarget(j, 2))
+          .Cells(l, o + 2).Value = RegReplace(CStr(vntTarget(j, 1)), "[A-Za-z]+", "", True)
+          l = l + 1
+        End If
+      Next j
+      ' ブロック毎に数値順にソート
+      .Range(.Cells(k, o), .Cells(l - 1, o + 2)).Sort _
+              key1:=.Cells(k, 3), _
+              Order1:=xlAscending, _
+              Header:=xlNo, _
+              OrderCustom:=1, _
+              MatchCase:=False, _
+              Orientation:=xlTopToBottom, _
+              SortMethod:=xlPinYin, _
+              DataOption1:=xlSortTextAsNumbers
+      ' ソート用に使用した数値列を削除
+      .Range(.Cells(k, o + 2), .Cells(l - 1, o + 2)).ClearContents
+      k = l
+    Next i
+  End With
+  Set xlSheet = Nothing
+  Set xlBook = Nothing
+End Sub
+```
+改善点は２箇所です。
+まず、ソートそのものに関する改善は下記１行のみです。
+`If RegMatch(CStr(vntTarget(j, 1)), "^" & strOrder(i) & "[0-9]") Then`
+ソートの基準になる「英字部分」のマッチングで、余計な文字列がマッチしてしまわぬよう「正規表現」を以下のように変更しました。
+```
+修正前）strOrder(i)
+修正後）"^" & strOrder(i) & "[0-9]"  ← 文字列の「先頭」〜「最初の数字」までをマッチング
+```
+もう一箇所はついで（本質的ではない）ですが、ソートの基準になる英文字部分の定義に「動的配列」を使用することで、追加や順序の入れ替えを楽に出来るようにしてみました。
+以上、ご参考になれば幸いです。