正規表現を用いての並び替え

Question

おはようございます
前回、ローマ字、ハイフンを含む並び替えで正規表現を用いての並び替えを教えていただきました。その際A列を例題として解答していただきましたが、列（G列11行～最終行）を変更して行った結果うまくいきません大変申し訳ありませんがお教えください。

Sub Q12878498()
Dim re As Object, mc As Object
Dim n As Long, v()

Set re = CreateObject("VBScript.RegExp")
re.Pattern = "^(\D+)?(\d+)-?(\d+)?$"
n = Cells(Rows.Count, 1).End(xlUp).Row
If n < 2 Then Exit Sub

ReDim v(1 To n, 1 To 3)
For rw = 2 To n
Set mc = re.Execute(Cells(rw, 1).text)
If mc.Count > 0 Then
v(rw, 1) = mc.Item(0).SubMatches(0) & " "
v(rw, 2) = mc.Item(0).SubMatches(1)
v(rw, 3) = mc.Item(0).SubMatches(2)
If v(rw, 3) = "" Then v(rw, 3) = -1
End If
Next rw

Application.ScreenUpdating = False
Range("A:C").Insert
Cells(1, 1).Resize(n, 3).Value = v
Cells(2, 1).Resize(n - 1, 4).Sort _　　　　　　'ソート範囲はCells(2, 1).Resize(n - 1, 5)
key1:=Range("A2"), key2:=Range("B2"), key3:=Range("C2")
Range("A:C").Delete
Application.ScreenUpdating = True
End Sub

上記のVBAにより、わかる範囲でセル（行、列）を変更してみました行変更に対しては何とかできましたが列を変更するとできません。どこの箇所を変更したらよいのでしょうか。

fujillin · Accepted Answer

こんばんは

前回回答者です。

＞A列を例題として解答していただきましたが、列（G列11行～最終行）
＞を変更して行った結果うまくいきません
今更ですが、セル位置程度の話であれば、初めからその位置でご質問をなされば面倒な問題は起きなかったのにと思います。

また、「前回」としか書いていないので、どのような質問だったのかは他の方には読み取れない可能性があります。
（プロフィールで質問履歴を非公開にしていますし）
コードだけ見せられても（処理の内容は理解できても）、「実際になさりたいこと」を読み解くのは面倒なことですので。

既に、他の方が回答してくださっているので、そちらをご利用なさっても宜しいかと思いますが、ひとまず回答した手前、ご質問のコードをそのままの形式で書き直してみました。

※ 並べ替えの対象となるセル範囲の1行目を、targetCellsとして設定しておきます。
（G11がタイトル行の場合は、実データの始まるG12:H12に修正してください）
※ このtargetCellsの示す範囲に対して、処理が行われるように内容を変更しました。
（一部のロジックを微修正してあります。）

Sub Q12883177()
Dim re As Object, mc As Object
Dim tr As Range, n As Long, v()

Const targetCells = "G11:H11" '←並べ替え対象の範囲

Set tr = Range(targetCells).Rows(1).Cells
n = Cells(Rows.Count, tr(1).Column).End(xlUp).Row - tr(1).Row + 1
If n < 1 Then Exit Sub

Set re = CreateObject("VBScript.RegExp")
re.Pattern = "^(\D+)?(\d+)-?(\d+)?$"
ReDim v(1 To n, 1 To 3)

For rw = 1 To n
Set mc = re.Execute(tr(1).Offset(rw - 1).text)
If mc.Count > 0 Then
v(rw, 1) = mc.Item(0).SubMatches(0) & " "
v(rw, 2) = mc.Item(0).SubMatches(1) * 1
v(rw, 3) = mc.Item(0).SubMatches(2)
If v(rw, 3) = "" Then v(rw, 3) = -1
v(rw, 3) = v(rw, 3) * 1
End If
Next rw

Application.ScreenUpdating = False
tr(1).Resize(, 3).EntireColumn.Insert
tr(1).Offset(, -3).Resize(n, 3).Value = v
tr(1).Offset(, -3).Resize(n, tr.Columns.Count + 3).Sort _
key1:=tr(1).Offset(, -3), key2:=tr(1).Offset(, -2), key3:=tr(1).Offset(, -1)
tr(1).Offset(, -3).Resize(, 3).EntireColumn.Delete
Application.ScreenUpdating = True

End Sub

Qchan1962 · Answer

こんにちは大分にぎわいましたが、＞Range("b11:x" & zsg).Sort key1:=Range("g11")　・・・・　となると　部分的な並び替えではない　ので大分内容が異なりますね各キーのデータの作り方は前出の関数でおおよそ想像できるのですが今回は、各Key列はどこから作られるのでしょう？と思います。 g11 i11 j11　各列最終行まで　の値（元データ）をアルファベット　数値　数値　に加工してSortキーワードにするのでしょうか？ご質問の流れからキーが9列？・・・私が回答できるかは分かりませんが、整理して　再質問されるのが良いと思いますね（元データのパターンは明確に）アルファベットだけの値の有無とか大文字の有無、優先順位とか・・・（現状大文字が優先）回答追加した　ついでに＃４の文字列作成、加工部分をVBScript.RegExpで取得すると For i = 1 To UBound(ary, 1) Dim reg As Object Set reg = CreateObject("VBScript.RegExp") reg.Pattern = "^(\D+)?(\d+)-?(\d+)?$" With reg.Execute(ary(i, 1)) If .Count > 0 Then If .Item(0).SubMatches(2) <> "" Then ary(i, colm) = .Item(0).SubMatches(1) * 1000 + .Item(0).SubMatches(2) Else ary(i, colm) = .Item(0).SubMatches(1) * 1000 End If If .Item(0).SubMatches(0) <> "" Then ary(i, colm) = .Item(0).SubMatches(0) & ary(i, colm) Else ary(i, colm) = "zz" & ary(i, 1) & 10 ^ i　'文字列のみの場合の最下位に回す対応（シートソートでないのでやっつけ） End If End With Next i 優先キーを作成するのが大変なので数値加工で対応しているので　破綻する可能性があります？文字列のみをアルファベット順位（数値があるもの）に組み込む場合は \D+　を小文字にして対応してください（現状最下位）私的には配列より正規表現の方が判り難いと思いますが慣れかな？

tatsumaru77 · Answer

No3です。
>ソートできましたが、文字例 1-1等が1/1/2022ように日付表示されました。

前回のは破棄してください。こちらを採用してください。
なお、必ず実行前にG列の「セルの書式設定」を文字列に設定してください。

Public Sub 指定列ソート()
    Const 処理列 As String = "G"
    Const 開始行 As Long = 11
    Dim RE As Object
    Dim mc As Object
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow As Long
    Dim row1 As Long
    Dim row2 As Long
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^(\D+)?(\d+)-?(\d+)?$"
    Set sh1 = ActiveSheet
    maxrow = sh1.Cells(Rows.count, 処理列).End(xlUp).Row
    If maxrow < 開始行 Then Exit Sub
    Application.ScreenUpdating = False
    Worksheets.Add after:=Worksheets(Worksheets.count)
    Set sh2 = Worksheets(Worksheets.count)
    sh2.Columns("D:D").NumberFormatLocal = "@"
    row2 = 0
    For row1 = 開始行 To maxrow
        row2 = row2 + 1
        Set mc = RE.Execute(sh1.Cells(row1, 処理列).text)
        If mc.count > 0 Then
            sh2.Cells(row2, "A").Value = mc.Item(0).SubMatches(0) & " "
            sh2.Cells(row2, "B").Value = mc.Item(0).SubMatches(1)
            sh2.Cells(row2, "C").Value = mc.Item(0).SubMatches(2)
            If sh2.Cells(row2, "C").Value = "" Then sh2.Cells(row2, "C").Value = -1
        End If
        sh2.Cells(row2, "D").Value = sh1.Cells(row1, 処理列).Value
    Next
    sh2.Cells(1, 1).Resize(maxrow - 開始行 + 1, 4).Sort key1:=Range("A1"), key2:=Range("B1"), key3:=Range("C1")
    sh1.Cells(開始行, 処理列).Resize(maxrow - 開始行 + 1, 1).Value = sh2.Cells(1, "D").Resize(maxrow - 開始行 + 1, 1).Value
    Application.DisplayAlerts = False
    sh2.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Qchan1962 · Answer

こんにちは、#2で回答したものです状況は良く分かりませんが、お示しのコードに手を加えるのは控えさせて頂き、アイデアについては＃３様が回答されていますので前回 https://oshiete.goo.ne.jp/qa/12878498.html のご質問で私が回答したものに手を加えてコードにしてみます文字列はローマ字、数値、ハイフンとの組み合わせと理解していますが明確な文字列パターンが不明なのでVBScript.RegExpを呼ばず　Like "[0-9-@]" と取敢えず1文字ずつ取得して、前での関数式を基に数値を作り順位キーワードにしています。明確な文字列パターンがあるようならば、ご質問のコードにあるようにVBScript.RegExpを呼び、処理をされるのが良いと思います。今回も内容が分からないと思いますが、　配列でのソート Sub mySort_alphabet_hyphen() Call ArrayInsertionSort _ (Range(Cells(11, "G"), Cells(Rows.Count, "G").End(xlUp)).Resize(, 5)) End Sub Sub ArrayInsertionSort(Rng As Range) Dim ary(), tp(), s Dim i As Long, n As Long, k As Long, colm As Long Dim moji As String Dim tmp1, tmp2 If Rng.Count <= 1 Then Exit Sub ary = Rng.Value ReDim Preserve ary(1 To UBound(ary, 1), 1 To UBound(ary, 2) + 1) colm = UBound(ary, 2) ReDim tp(1, 1 To colm) For i = 1 To UBound(ary, 1) '文字列作成 For k = 1 To Len(ary(i, 1)) moji = Mid(ary(i, 1), k, 1) If moji Like "[0-9-@]" Then tmp1 = tmp1 & moji Else tmp2 = tmp2 & moji Next '文字（数値）加工・・　配列へ　2が加工数値 n = n + 1: s = Split(tmp1, "-") If tmp1 <> "" Then If tmp2 = "" Then If UBound(s) = 0 Then ary(n, colm) = s(0) * 1000 Else ary(n, colm) = s(0) * 1000 + s(1) Else If UBound(s) = 0 Then ary(n, colm) = tmp2 & s(0) * 1000 Else ary(n, colm) = tmp2 & s(0) * 1000 + s(1) End If End If tmp1 = "": tmp2 = "" Next '配列次元 UBoundキーで挿入Sort For n = LBound(ary) + 1 To UBound(ary) For i = 1 To colm tp(1, i) = ary(n, i) Next If ary(n - 1, colm) > tp(1, colm) Then k = n Do While k > LBound(ary) If ary(k - 1, colm) <= tp(1, colm) Then Exit Do End If For i = 1 To colm ary(k, i) = ary(k - 1, i) Next k = k - 1 Loop For i = 1 To colm ary(k, i) = tp(1, i) Next End If Next '結果出力 Rng(1).Resize(UBound(ary), colm - 1) = ary End Sub 実行プロシージャ Sub mySort_alphabet_hyphen() Call ArrayInsertionSort _ (Range(Cells(11, "G"), Cells(Rows.Count, "G").End(xlUp)).Resize(, 5)) G11セルから最終行の範囲をResize(, 5)右に拡張した範囲が対象並び替えキーワード列は一番左の列、範囲は可変並び替え数値（加工数値）は2次元側最大に格納降順はソート部分不等式を反転及び変更注意＊　'結果出力は Rng(1).　なので上書きされます。テストされる場合は、コピーブックなどで実験データ　左が前期待する順番になっていない様であればキーワードに問題があるので　'文字列作成、文字（数値）加工を検討してください。

tatsumaru77 · Answer

以下のようにしてください。
もし、現行のA列2行からに変えたい場合は、
    Const 処理列 As String = "G"
    Const 開始行 As Long = 11
を
    Const 処理列 As String = "A"
    Const 開始行 As Long = 2
にしてください。
上記を変更すれば、任意のセルのソートができます。

----------------------------------------------------------
Public Sub 指定列ソート()
    Const 処理列 As String = "G"
    Const 開始行 As Long = 11
    Dim RE As Object
    Dim mc As Object
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow As Long
    Dim row1 As Long
    Dim row2 As Long
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^(\D+)?(\d+)-?(\d+)?$"
    Set sh1 = ActiveSheet
    maxrow = sh1.Cells(Rows.count, 処理列).End(xlUp).Row
    If maxrow < 開始行 Then Exit Sub
    Application.ScreenUpdating = False
    Worksheets.Add after:=Worksheets(Worksheets.count)
    Set sh2 = Worksheets(Worksheets.count)
    row2 = 0
    For row1 = 開始行 To maxrow
        row2 = row2 + 1
        Set mc = RE.Execute(sh1.Cells(row1, 処理列).text)
        If mc.count > 0 Then
            sh2.Cells(row2, "A").Value = mc.Item(0).SubMatches(0) & " "
            sh2.Cells(row2, "B").Value = mc.Item(0).SubMatches(1)
            sh2.Cells(row2, "C").Value = mc.Item(0).SubMatches(2)
            If sh2.Cells(row2, "C").Value = "" Then sh2.Cells(row2, "C").Value = -1
        End If
        sh2.Cells(row2, "D").Value = sh1.Cells(row1, 処理列).Value
    Next
    sh2.Cells(1, 1).Resize(maxrow - 開始行 + 1, 4).Sort key1:=Range("A1"), key2:=Range("B1"), key3:=Range("C1")
    sh1.Cells(開始行, 処理列).Resize(maxrow - 開始行 + 1, 1).Value = sh2.Cells(1, "D").Resize(maxrow - 開始行 + 1, 1).Value
    Application.DisplayAlerts = False
    sh2.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Qchan1962 · Answer

こんばんは
書かれた方を待つのが良いと思いますが、

自身で出来そうなアイデアとして
A列で実行すれば出来るのであれば、（大前提）

並び替えたい範囲（元データ）を別シート（新規シートなど）A列以降に書き出し、
別シートで処理を実行
結果を元データ範囲に代入

元データの貼り付け　と　加工データの取得処理を加えるだけになると思います。
列の挿入や削除があるので、その方が判り易いかな。。

めぐみん_ · Answer

直接の回答ではありませんが。

個人的には Cells で行・列を指定するとき、特に列の場合は列番号より列記号を用いるようにしてますね。

例えばセルＡ１なら
Cells(1 , 1) よりも Cells(1 , "A") の方が Range("A1") に表示が近いので、わかりやすくなるかなと初級レベルなジジィは思ってしまうので。

正規表現を用いての並び替え

こんばんは

こんにちは

No3です。

こんにちは、#2で回答したものです

以下のようにしてください。

こんばんは

直接の回答ではありませんが。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング