エクセル VBAのソートに関して

エクセルのVBAに関して質問させて頂きます。
使用しているエクセルは2003です。

現在下記の動作をさせるものを作成したいのですが、
効率のいい方法が思いつきません。

エクセルシートの"A1"から”A800"までのセルに
「"Z1~~Z100","Y1~~Y100","WX1~~WX200","UV1~~UV200" ,"ST1ST200"」
の文字列がそれぞれにバラバラ格納されています。
このとき"A1A800”の中で重複している内容はありあせん。
また、上の文字列はそれぞれ100200種類用意されていますが、
"A1A800"が毎回全て埋まるわけではなく、なおかつ全ての種類を使用しているとは限りません。
全部のデータが今回は100個しかなく、"Z"は"Z7~Z11,Z23,Z25"がランダムに、残りは全て"UV"と"WX"で埋め尽くされているということもあるということです。

また"B"の行にはそれぞれデータ"A"の行に対応した値が格納されています。
Bの行には重複があります。

このとき、これらのデータを"A"行をキーとしてソートをかけると
Z1
Z10
Z11
・
・
Z2
Z21
となってしまいます。

これを
Z1
Z2
Z3
と最初の文字を無視した形でソートしたいのです。

なおかつ、
ソートの順番は "Z" "WX" "ST" "UV" "Y"
で行いたいのですがなにか方法はあるでしょうか？
文章だけでは説明が分かりにくいと思うので画像添付いたします。

追記
ta-kun様

追記
どれも大変すばらしくとても助かりました。
ありがとうございました。
ベストアンサーに関しましては私の個人的な好みと実際にそちらをベースとさせて
頂いたので選ばせて頂きました。
しかし、これとはいわず、それぞれのやりやすさ好みもあると思いますので
同じ壁にぶつかった方は皆様の回答をそれぞれ参考にして頂きたく思います。

Connect-a

2015/11/11 03:52

はじめましてまだ回答を募集していますか？いまコードをかける環境にないので夜に投稿をしようと思うのですが。

行動規範の内容に同意します

回答8件

VBAではありませんが、
一列追加してそこに関数を入れると
=VALUE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A1,"Z",""),"Y",10),"WX",2000),"UV",300000),"ST",40000000))
これで多分
Z -> 1～100
Y -> 101～10100
WX -> 20001～2000200
UV -> 3000001～300000200
ST -> 400000001～40000000200
このような数値になるので、あとはこの数値をキーにソートできないでしょうか？
終わった後は数値列削除でいいと思います。
※excelが手元に無いので動くか自信がありませんが、セルでは15桁までの数値を扱えるようです。

投稿2015/11/02 12:02

編集2015/11/02 12:04

hirohiro

総合スコア2068

nodact

2015/11/02 12:20

ご回答ありがとうございます。試してみたのですが、うまくできました！ここで質問なのですが、現在は先頭文字の種類が5種類ですが、これが今後増えていき20種類とかになった場合の改善策などはなにかございますでしょうか？

hirohiro

2015/11/02 15:30 編集

その際はVBAでスクリプトを作成するか、仕様変更が可能ならソートしやすいようにキーの文字を工夫するかすれば良いと思います。(trickさんがおっしゃるようにZ001のようにしたり、アルファベット順も無視したいなら01Z001のように先頭に数字をつけたり) VBでやるにしても、結局キーを文字と数値に分解して、並べやすいように整形するか分類して、並べて出力という手順になると思います。

hsk

2015/11/26 09:10 編集

こんにちは。 B列へ1行挿入して次の式を各行に指定し、この値をソートキーとすれば、今後先頭文字の種類が増えても大丈夫でしょう。 =MATCH(MID(A1,1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},ASC(A1)&1234567890,1))-1),D$2:D$7,0) * 1000 + VALUE(MID(A1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},ASC(A1)&1234567890,1)),100)) 上記式の"D$2:D$7"は、（ご質問の追記のような）ソート順にならべた先頭文字のセル範囲に応じて変更します。また、1000は、数字部分の最大値+1以上の数字（最大999であれば1000）、100はA列に指定された文字列の長さの最大以上であればOKです。

hsk

2015/11/26 09:23 編集

別解としては、「ユーザー設定リストによるソート」を使う方法があります。 B列に=MID(A1,1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},ASC(A1)&1234567890,1))-1) C列に=VALUE(MID(A1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},ASC(A1)&1234567890,1)),100)) の式を挿入し、最優先キーにB列(値：ユーザー指定)、第二キーにC列(値：昇順)を用いて並び替えを行います。 http://www.atmarkit.co.jp/fwin2k/win2ktips/440excelsort/excelsort.html 文字部分と数字部分を分離して並び替えるので、わかりやすいかと思います。これを使うならばシートに文字部分のソート順を入力する必要はなくなります。

行動規範の内容に同意します

考え方はhirohiroさんとほぼ同じですが、別案として。
VBAではありませんが。

●まずF列～G列に以下のような頭文字のマスタを用意します。

(F列)	(G列)
KEY	NUM
ST	40000
UV	 30000
WX	 20000
Y	10000
Z	0

※VLOOKUPで参照する情報なので、別シートに用意しても構いません。
※検索キー(頭文字)の順にソートされている必要があります。

●次にソート用としてC列・D列に式を埋め込みます。

C列で数値部分の開始位置を算出します。

(C2セルの内容)
=MIN(FIND({0,1,2,3,4,5,6,7,8,9},ASC(A2)&1234567890,1))

※D列の式内に含めてもよかったのですが、このほうがわかりやすかったので。

D列でソート順を算出します。

(D2セルの内容)
=VLOOKUP(LEFT(A2,C2-1),F$2:G$7,2,FALSE)+MID(A2,C2,999)

D列でソートすれば目的の順に並びかわると思います。

応用として、VLOOKUPの参照範囲(F$2:G$7)に名前を付けておくと
候補が増えたときに名前の範囲変更で対応できるので便利です。
例）名前：SORTKEY
範囲：F$2:G$7
(D2セルの内容)
=VLOOKUP(LEFT(A2,C2-1),SORTKEY,2,FALSE)+MID(A2,C2,999)

投稿2015/11/05 07:56

jawa

総合スコア3020

jawa さんが説明されていたことを、
少しアレンジして簡単に図示してみました。
ご参考まで。

投稿2015/11/23 10:11

ExcelVBAer

総合スコア1175

ベストアンサー

遅ればせながら私の回答を投稿いたします。

VBA
1Option Explicit
2
3Sub SortTool()
4    
5    '定数
6        'Split分割時カラム
7        Const IDcol = 0
8        Const TYPEcol = 1
9        Const NUMcol = 2
10        Const DATAcolShift = 1
11        Const WEIGHTcolShift = 2
12        
13    '設定定数
14        '元データID範囲
15        Const IDrange = "A2:A21"
16        '出力表貼り付け開始位置
17        Const outputListStartPosition = "D2"
18        'ソート順情報
19        Const sortOrder = "Z,WX,ST,UV,Y"
20        'テーブル名
21        Const tableName = "データテーブル"
22        'テーブルとして書式設定するか
23        Const listFlag = False
24        
25    '左端列格納配列
26    Dim iDArray() As Variant
27    iDArray = Me.Range(IDrange)
28    
29    'for文用
30    Dim IDnum As Long
31    Dim charNum As Long
32    'ID一時保存
33    Dim IDstr As String
34    
35    '機能①：データ変換 （元データ,文字部分,数値部分）
36        For IDnum = LBound(iDArray) To UBound(iDArray)
37            'ID取得
38            IDstr = iDArray(IDnum, 1)
39            '要素に区切り文字設定
40            iDArray(IDnum, 1) = iDArray(IDnum, 1) + ","
41        '１文字ずつ読み込み
42            For charNum = 1 To Len(IDstr)
43                '読み込んだ１文字が数値でなかった場合
44                If Not IsNumeric(Mid(IDstr, charNum, 1)) Then
45                    'IDの最後に追加
46                    iDArray(IDnum, 1) = iDArray(IDnum, 1) + Mid(IDstr, charNum, 1)
47                Else
48                    '※IDに数値が入ってはいけない
49                    Exit For
50                End If
51                
52            Next
53            
54        '数値部分を取得
55            IDstr = Replace(IDstr, Split(iDArray(IDnum, 1), ",")(TYPEcol), "")
56        'IDに区切り文字と数値部分をくっつける
57            iDArray(IDnum, 1) = iDArray(IDnum, 1) + "," + IDstr
58            
59        Next
60        
61    '機能②：「機能①」で変換したデータの貼り付け
62        '貼り付け列
63        Dim pasteColumn As Long
64        pasteColumn = Me.Range(outputListStartPosition).Column
65        '貼り付け位置ずらし値
66        Dim pasteColumnShift As Long
67        pasteColumnShift = UBound(Split(iDArray(1, 1), ","))
68        Dim pasteRowShift As Long
69        pasteRowShift = Range(outputListStartPosition).Row - 1
70        
71        'for文用(貼り付け位置)
72        Dim pasteRow As Long
73        'for文用(ソート文字列参照)
74        Dim orderItem As Variant
75        Dim orderItemCounter As Long
76        
77        '出力表貼り付け終了位置
78        Dim outputListLastPosition As Range
79        
80        For pasteRow = LBound(iDArray) + pasteRowShift To UBound(iDArray) + pasteRowShift
81            '貼り付け
82            Range(Me.Cells(pasteRow, pasteColumn), Me.Cells(pasteRow, pasteColumn + pasteColumnShift)) = Split(iDArray(pasteRow - pasteRowShift, 1), ",")
83            '数値部分を数値型に
84            Me.Cells(pasteRow, pasteColumn + pasteColumnShift) = Val(Me.Cells(pasteRow, pasteColumn + pasteColumnShift))
85            
86            With Me.Cells(pasteRow, pasteColumn + pasteColumnShift)
87            '紐づけデータ（右端）取得
88                .Offset(, DATAcolShift) = Me.Range(IDrange).Cells.Find(Split(iDArray(pasteRow - pasteRowShift, 1), ",")(IDcol), LookAt:=xlWhole).Next
89            
90            '機能②-1：ソート順重みづけ-------------------
91                orderItemCounter = 0
92                For Each orderItem In Split(sortOrder, ",")
93                    If Split(iDArray(pasteRow - pasteRowShift, 1), ",")(TYPEcol) = orderItem Then
94                        .Offset(, WEIGHTcolShift) = orderItemCounter
95                    End If
96                    orderItemCounter = orderItemCounter + 1
97                Next
98                'ソート文字列内になかった場合
99                If .Offset(, WEIGHTcolShift).Value = "" Then
100                    .Offset(, WEIGHTcolShift).Value = "9999"
101                End If
102            '---------------------------------------------
103            
104                '表終了位置を随時記録
105                Set outputListLastPosition = .Offset(, WEIGHTcolShift)
106            
107            End With
108            
109        Next
110        
111        'リスト削除用
112        Dim delList As Variant
113        'リスト化
114        If listFlag Then
115            '（見出し,セル幅設定）（テーブル化）
116            If Range(outputListStartPosition).Row > 1 Then
117                    Range(Me.Range(outputListStartPosition).Offset(-1), Me.Range(outputListStartPosition).Offset(-1, pasteColumnShift + WEIGHTcolShift)) _
118                        = Split("ID,TYPE,NUMBER,DATA,WEIGHT", ",")
119                For Each delList In Me.ListObjects
120                    If delList.Name = tableName Then
121                        delList.Unlist
122                    End If
123                Next
124                'テーブル化
125                Range(Me.Range(outputListStartPosition).Offset(-1), outputListLastPosition).ClearFormats
126                ListObjects.Add( _
127                    xlSrcRange, _
128                    Range(Me.Range(outputListStartPosition).Offset(-1), outputListLastPosition), , _
129                    , xlYes, "TableStyleMedium1").Name = tableName
130                
131                'ソート
132                Range(tableName).Sort , _
133                    key1:=Me.Range(outputListStartPosition).Offset(, pasteColumnShift + WEIGHTcolShift), order1:=xlAscending, _
134                    key2:=Me.Range(outputListStartPosition).Offset(, NUMcol), order2:=xlAscending, _
135                    Header:=xlYes
136            End If
137            
138       'リスト化しない
139       Else
140                'ソート
141                Range(Me.Range(outputListStartPosition), outputListLastPosition).Sort , _
142                    key1:=Me.Range(outputListStartPosition).Offset(, pasteColumnShift + WEIGHTcolShift), order1:=xlAscending, _
143                    key2:=Me.Range(outputListStartPosition).Offset(, NUMcol), order2:=xlAscending, _
144                    Header:=xlNo
145       End If
146        
147End Sub
148

実行後イメージは下記のとおりです。
・listFlag = True

・listFlag = False

投稿2015/11/11 15:53

編集2015/11/12 13:45

Connect-a

総合スコア15

nodact

2016/02/03 00:16

最終評価が終了し、こちらを採用させて頂きましたのでベストアンサーとさせて頂きました。大変助かりました。ありがとうございました。

nodact

2016/04/05 10:22

すいません。いまさらになってしまうのですが、コード中にエラーが発生してしまいました。もしよろしければご教授いただけたら幸いです。箇所は '左端列格納配列 Dim iDArray() As Variant iDArray = Me.Range(IDrange) の部分になりまして、メソッドまたはデータメンバが見つかりません。となります。この中で「.Range]の部分がいけないということです。お分かりになるでしょうか？

行動規範の内容に同意します

計算列を３つも使ってしまいますが、下記で自動ソート出来ます。

まず、ソート順のキーをD列に入力します。

(D列)
ソート順
Z
WX
ST
UV
Y

F列（数字のみ取り出す）
=LOOKUP(10^17,RIGHT(A1,COLUMN(1:1))*1)

G列（文字をソート順インデックスにより数値化し、F列の最大値を利用しユニークな数値を作成）
=MAX(F$1:F$10)*MATCH(SUBSTITUTE(A1,F1,""),$D$2:$D$6,0)+F1

H列（G列を小さい順にソートし、インデックス値を計算）
=MATCH(SMALL(G$1:G$10,ROW()),G$1:G$10,0)

I列（H列に従い、抽出）
=INDEX(A$1:A$10,$Q1)
J列（H列に従い、抽出）
=INDEX(B$1:B$10,$Q1)

後は、F1からJ1を下方向にオートフィルコピー

ソート順キーを増やした場合、G列の$D$2:$D$6を修正してください。

投稿2015/11/06 06:55

ta-kun

総合スコア59

ta-kun

2015/11/06 06:59

補足です。 F列の最大値がある程度想定できるのあれば、 MAX(F$1:F$10)を、10000など固定値にしてもOKです。

nodact

2015/11/09 01:03

ご回答ありがとうございます。ご返事が遅れてしまい申し訳ございません。私の質問欄にta-kun様へということで画像を追加させて頂きました。現状画像のようになってしまうのですがなにか原因は分かりますでしょうか？

ta-kun

2015/11/10 08:24 編集

G列の式 MAX(F$1:F$10)のF$10部は、データのある行まで指定する必要があります。画像のデータの場合、F$1:F$20となります。同様に、 H列のG$1:G$10部（２か所） I列のA$1:A$10 J列のB$1:B$10 もすべて、$20としてください。う～ん、データ数に応じて、変更の必要があるのが少し不便ですね。 COUNTAとINDIRECT使えば、自動計算も出来ますね。

ta-kun

2015/11/10 08:28

nodactさん Y09のような数値部の先頭に、０があると、私の計算式では対応出来ませんね。中途半端に終わってしまい、すみません。

行動規範の内容に同意します

こんな感じでどうですか？
あまりテストしていませんがそれっぽい動作はしました。
コードが増えてもメンテ不要なコードです。
（コードに英数以外が増えた場合は1行目の"00"を増やす必要があります）

①ソート用のキーを作成するユーザ関数を作成します。

VBA
1Const format As String = "00"
2Public Function getStringCode(ByVal value As String) As String
3
4    getStringCode = ""
5    If value = "" Then Exit Function
6    
7    Dim i As Long
8    For i = 1 To Len(value)
9        getStringCode = getStringCode & Left(Asc(Mid(value, i, 1)) + format, Len(format))
10    Next
11
12End Function

②Excelシートの空いている列のすべてのデータ行に上記関数を埋め込みます。
=getStringCode([キーの値])

③上記の値でソートを行います。
※「数値に見えるものはすべて数値として並べ替えを行う」でソートする。

やっぱり↓の方がVBA使わないし断然楽かも。

①suffix列には以下の数式を入れます。
=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE([key列のセルを指定],"0",""),"1",""),"2",""),"3",""),"4",""),"5",""),"6",""),"7",""),"8",""),"9","")

上記数式により、0～9の文字が除去され、頭文字だけ取得できます。

②code列には以下の数式を入れます。
=RIGHT([key列のセルを指定],LEN([key列のセルを指定])-LEN([suffix列のセルを指定]))

上記数式により、頭文字を除いた数値部分だけ取得できます。

③②①の順でキー指定してソートするとご希望の順番に並び変わります。

投稿2015/11/06 01:06

編集2015/11/06 03:57

lilithchan

総合スコア249

ソート対象のデータが記載されているシートの名前を「Sheet1」として、A列に英字から始まるユニークな英数字のデータ、B列に重複ありのデータが格納されているとした場合、以下のVBAコードでソートできます。

英字部分のソート順序は、文字型配列の「strOrder」に定義しておきます。
ソート結果の出力先（列番号）は、Long型変数「o」に定義しておきます。
（下記サンプルでは 1 になっているので、元データの上にソート結果を上書きします。別の列に出力したい場合は、たとえば 5 としてください。そうすれば E〜F列に出力されます。）

入力済みの最終行を自動的に検出してソートしますので、データ数が増減しても対応できます。
また、先頭文字の種類が増えても、「strOrder」の定義を追加すれば対応できます。
（「strOrder」の定義は、たとえば別の設定シートを準備しておいて、そこに記載した行数に応じて自動的に読み込んで定義するようにも変更できます。）

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(5) 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")
  
  ' 文字列部の並び順の指定
  strOrder(1) = "Z"
  strOrder(2) = "WX"
  strOrder(3) = "ST"
  strOrder(4) = "UV"
  strOrder(5) = "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)) 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

＜コード修正：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]"  ← 文字列の「先頭」〜「最初の数字」までをマッチング

もう一箇所はついで（本質的ではない）ですが、ソートの基準になる英文字部分の定義に「動的配列」を使用することで、追加や順序の入れ替えを楽に出来るようにしてみました。

以上、ご参考になれば幸いです。

投稿2015/11/02 19:37

編集2015/11/05 11:58

pi-chan

総合スコア5936

nodact

2015/11/04 00:42

ご回答ありがとうございます。この条件の下動かせて頂いたのですが無事動きました。１点質問させて頂きたく思います。先頭文字の文字数の種類を増やして動かしてみたところ、先頭文字が3文字の場合(WXX）などの場合に結果が先頭文字3文字のものだけだぶって出力されて元データの数に対して結果データが多く出てきています。こちらは対応可能でしょうか？

nodact

2015/11/04 01:52 編集

すいません。もう一点追加でご質問させて頂きます。 ' 文字列部の並び順の指定で strOrder(1) に格納されるものが今回のデータの中にはなかった場合、 ' ブロック毎に数値順にソート .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 の部分で、実行時エラー "1004": アプリケーション定義またはオブジェクト定義のエラーです。と出てきてしまうのですがこちら何か対策は可能でしょうか？追記. ソートを行ったときに Z29 Z5 Z2 というデータを並び替えた場合、現在だと Z2 Z29 Z5 とい風になってしまうのを Z2 Z5 Z29 のようにしたいのですが、こちらはプログラムに組み込むことは可能でしょうか？やり方は様々あるようですが、hirohiroさんやtrickさんがおっしゃるようにZ02のように"0"を一時的に組み込むという方法もあるようですがなにか他にも手段はあるのでしょうか？

pi-chan

2015/11/04 04:50

要件さえハッキリしていれば、いずれも対応可能です。今移動中なので、しばしお待ちください。明朝までに回答欄に追記しておきます。

nodact

2015/11/04 12:06

お忙しい中、ご回答ありがとうございます。ご教授の方よろしくお願い致します。

行動規範の内容に同意します

Z1 Z11 Z2 は文字列なので単純なソートでは Z1 Z2 Z11 にはなりません
私もエクセルの機能を全て知っているわけでは無いので簡単な方法があるのかも知れませんが
私の考えを記載します

Z1 を Z001 等に変更できませんか？
それであれば文字列でも正しくソートが可能です。

投稿2015/11/02 11:08