ファイル名「1.jpg ～10.jpg～」のソート

質問

ただ今、エクセルのvbaを使って
複数の写真ファイルを一気に貼り付けてJPEGに変換するプログラムを作っています。
だいたいはできたのですが、一つ壁にぶつかりました。

アルゴリズムは指定したフォルダのファイル名を取得し、それをリスト用のシートに出力し、使用者に必要なファイルを取捨選択してもらうようにしています。

フォルダのファイル名は下記URLのサンプルから使わせていただいています。

http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html

しかし、これを使うと、

「1.jpg、2.jpg～10.jpg・・・」のファイル名を取得すると、
「1.jpg、10.jpg、2.jpg・・・」

という風になります。これを回避するには現状「01.jpg、02.jpg～10.jpg・・・」と名前をつけるしかないのですが、不特定多数の人に使わせるので、出来るだけ汎用性を持たせたいと思っています。

例えば

「テスト1-1.jpg、テスト1-2.jpg～テスト1-10.jpg・・・
テスト10－1.jpg、テスト10-2.jpg～テスト10-10.jpg・・・
テスト11-1.jpg、テスト11-2.jpg～テスト11-10.jpg・・・」

というファイル名を上の通りに並べ変えるとしたら、どうすればいいでしょうか？

難しい場合は
「01.jpg、02.jpg～10.jpg・・・」

の時だけでもいいのでよろしくお願いします。

回答No.2

temtecomai2 · ベストアンサー

Windows XP 以降、エクスプローラーのファイル表示に使われているソート ルールってことですよね。（マイクロソフトの直観的なソート）

StrCmpLogicalW って API を使ってるっぽいです。

SortByIntuitiveFilename っていう関数を作ってみました。
文字列型の配列にファイル名の一覧を入れておいてこの関数に渡せばソートしてくれます。
一応テスト用のプロシージャ Sub Test() も載せておきます。

Option Explicit

Declare Function StrCmpLogicalW Lib "SHLWAPI.DLL" (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long

Sub SortByIntuitiveFilename(ByRef aFiles() As String)
Dim i As Long
Dim j As Long
Dim tmp As String
'Dim minIdx As Long
'Dim maxIdx As Long

'minIdx = LBound(aFiles)
'maxIdx = UBound(aFiles)

For i = LBound(aFiles) To UBound(aFiles)
For j = i To UBound(aFiles)
If StrCmpLogicalW(StrConv(aFiles(i), vbUnicode), StrConv(aFiles(j), vbUnicode)) > 0 Then
tmp = aFiles(i)
aFiles(i) = aFiles(j)
aFiles(j) = tmp
End If
Next
Next

End Sub

Sub test()
Dim strPath As String
strPath = "e:\test"

Dim fso As Scripting.FileSystemObject
Dim fld As Scripting.Folder
Set fso = New Scripting.FileSystemObject
Set fld = fso.GetFolder(strPath)

Dim fileNames() As String
Dim cnt As Long
cnt = fld.Files.Count
ReDim fileNames(cnt - 1)

Dim k As Long
k = 0
Dim f As Scripting.File
For Each f In fld.Files
fileNames(k) = f.Name
k = k + 1
Next

Call SortByIntuitiveFilename(fileNames)

End Sub

お礼

ありがとうございます！
これは、便利ですね。
StrCmpLogicalW という関数の仕様が見つからなかったので、ちょっと試してみた感じだと、XPのファイルシステムを使って二つのファイル名が降順だと1、同じなら0、昇順なら-1を返すってかんじっぽいですね。

これなら、XPのエクスプローラーとまったく同じ順序になるので、違和感もなくなると思います。

ありがとうございましたー

回答No.3

imogasi

ソートキーのためにシートの各行（ファイル名が入っている）の余分な空き列に、Format関数ででも、1や2を001,002に変換した文字列を作って持ち（12,23も012,023のようにする）、この列でエクセルでソートして、ソート後の結果を使えば良い、
作業列が嫌いなら配列に一時的にファイル名を持つ必要があるが、配列データのロジックも色々有り、テストも本来大変。
ーー
エクセルではシートのセルにあるデータ（内容）でしかソートできない。色々悩んでよい方法がないか、など考えても無駄。
ーー
ソートするルールは決っているのだ。それを勉強して、ユーザー（VBA内を作るもの）がそれに合うように修正ソートキーをどこかに作らざるをえないのだ。
ーーー
ーを挟んでも質問尾ことは解決されないのでは。桁調節のスペースが許されないケースでは。

お礼

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

「ーを挟んでも質問尾ことは解決されないのでは。桁調節のスペースが許されないケースでは。」

ハイフンとかいれた場合の質問をしても、質問箱では解決できないということですか？
又、format関数を用いた作業列を使うなら、ハイフンが邪魔で桁調整ができないということですかね。

format関数すら、この答えで知ったものですから私には難しいですが、桁調整の問題はNo.1番さんの答えで解決しました（ついでに作業列もありません）
しかし、format関数を使った作業列という案も十分な有効な策なので、どちらがいいかは吟味させていただきます

回答No.1

end-u

仮にA2以下に書き出されたファイル名をソートする場合、

Sub try()
　　Const MX　 As Long = 5 '取り敢えず各数値最大5桁の設定
　　Dim target As Range　　'並べ替え対象セル範囲
　　Dim r　　　As Range　　'Loop用
　　Dim rep　　As String　 'Format関数用
　　Dim tmp　　As String　 '整形前Value
　　Dim ret　　As String　 '整形後Text
　　Dim s　　　As String　 '文字１個
　　Dim ss　　 As String　 '連続数値文字
　　Dim x　　　As Long　　 'Len
　　Dim p　　　As Long　　 '桁数記憶用
　　Dim i　　　As Long
　　Dim j　　　As Long

　　Application.ScreenUpdating = False
　　'並べ替え対象のセル範囲をセット。
　　'サンプルとして(A2:A列最終行)
　　Set target = Range("A2", Cells(Rows.Count, 1).End(xlUp))

　　rep = String(MX, "0")
　　For Each r In target
　　　　tmp = r.Value
　　　　x = Len(tmp) + 1
　　　　'整形後Text長をMAXで設定
　　　　ret = Space(x * MX)
　　　　p = 0
　　　　j = 1
　　　　'１文字ずつLoop
　　　　For i = 1 To x
　　　　　　s = Mid$(tmp, i, 1)
　　　　　　If IsNumeric(s) Then
　　　　　　　　'数値だったら連続数をCountして連結
　　　　　　　　p = p + 1
　　　　　　　　ss = ss & s
　　　　　　Else
　　　　　　　　If p > 0 Then
　　　　　　　　　　'Format関数で桁合わせて連結
　　　　　　　　　　Mid$(ret, j, MX) = Format$(ss, rep)
　　　　　　　　　　j = j + MX
　　　　　　　　　　p = 0
　　　　　　　　　　ss = Empty
　　　　　　　　End If
　　　　　　　　'数値以外を連結
　　　　　　　　Mid(ret, j, 1) = s
　　　　　　　　j = j + 1
　　　　　　End If
　　　　Next
　　　　'整形後Textをふりがなにふる
　　　　r.Phonetic.Text = Left$(ret, j)
　　Next
　　'ふりがなSort
　　target.Sort Key1:=target.Item(1), Order1:=xlAscending, _
　　　　　　　　Header:=xlNo, OrderCustom:=1, _
　　　　　　　　MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　　　　　SortMethod:=xlPinYin

　　Application.ScreenUpdating = True
　　Set target = Nothing
End Sub

..こんな感じで。
地道Loop案なのでちょっと遅いかもしれませんが。

お礼

ありがとうございます！
ふりがなを設定すると、エクセルの既存の機能で、並び替えできるようになるんですか・・・

これは知らなかった。ふりがなってバカにできないですねぇ
勉強になります