excel 2010 範囲内 同じ文字 並べ替え

”現状”のように、「保第××」セルが3個、「高尾××」セルが2個、「山梨××」セルが1個。
一発処理で”以下の表がほしい”のようにしたいですが、分かる方のご指導をよろしくお願いします。

No.3 ベストアンサー 回答者： 30246kiku 回答日時： 2015/12/16 18:08

単純な以下でどうなりますか

指定したその場所で更新します

Public Sub Samp1()
　　Dim rng As Range
　　Dim v As Variant
　　Dim i As Long, j As Long

　　Set rng = Range("A2:D3") ' 場所指定
　　For i = 1 To rng.Count - 1
　　　　For j = i + 1 To rng.Count
　　　　　　If (rng(j) <> "") Then
　　　　　　　　If ((rng(i) = "") Or (rng(i) > rng(j))) Then
　　　　　　　　　　v = rng(i)
　　　　　　　　　　rng(i) = rng(j)
　　　　　　　　　　rng(j) = v
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Next
End Sub

※ 山梨と高尾の順が違いますけど


問い）

上記処理は単純に文字列として比較しているだけですが、
後ろの数字部分について
・２桁になることはありますか？
（高尾２ と 高尾１１ を単純比較すると、高尾１１、高尾２の順に）
・半角/全角混在しますか？
・数字前文字の出現個数が多い順ですか？

上記問いが全て「はい」で
・数字部分の始まりに 0 はない
・数字前にカタカナはない
の条件の時、雰囲気以下？


Public Sub Samp2()
　　Dim dic As Object, dicC As Object
　　Dim vA As Variant, vK As Variant, v As Variant
　　Dim vC As Variant
　　Dim sS As String, s As String
　　Dim i As Long, j As Long, k As Long, n As Long

　　Set dic = CreateObject("Scripting.Dictionary")
　　Set dicC = CreateObject("Scripting.Dictionary")
　　With Range("A2:D3")
　　　　vA = .Value
　　　　For i = 1 To UBound(vA)
　　　　　　For j = 1 To UBound(vA, 2)
　　　　　　　　If (vA(i, j) <> "") Then
　　　　　　　　　　sS = StrConv(vA(i, j), vbNarrow)
　　　　　　　　　　s = ""
　　　　　　　　　　n = 0
　　　　　　　　　　For k = 1 To Len(sS)
　　　　　　　　　　　　If (Mid(sS, k, 1) Like "[0-9]") Then
　　　　　　　　　　　　　　n = Val(Mid(sS, k))
　　　　　　　　　　　　　　sS = Left(vA(i, j), k - 1)
　　　　　　　　　　　　　　s = Mid(vA(i, j), k)
　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　End If
　　　　　　　　　　Next
　　　　　　　　　　If (s = "") Then sS = vA(i, j)
　　　　　　　　　　If (Not dic.Exists(sS)) Then
　　　　　　　　　　　　dic.Add sS, CreateObject("Scripting.Dictionary")
　　　　　　　　　　End If
　　　　　　　　　　dic(sS)(n) = s
　　　　　　　　　　vA(i, j) = ""
　　　　　　　　End If
　　　　　　Next
　　　　Next

　　　　For Each vK In dic.Keys
　　　　　　i = dic(vK).Count
　　　　　　If (Not dicC.Exists(i)) Then
　　　　　　　　dicC.Add i, CreateObject("Scripting.Dictionary")
　　　　　　End If
　　　　　　dicC(i)(vK) = Empty
　　　　Next

　　　　i = 1
　　　　j = 1
　　　　For Each vC In mySortDesc(dicC.Keys)
　　　　　　For Each vK In mySort(dicC(vC).Keys)
　　　　　　　　For Each v In mySort(dic(vK).Keys)
　　　　　　　　　　vA(i, j) = vK & dic(vK)(v)
　　　　　　　　　　j = j + 1
　　　　　　　　　　If (j > UBound(vA, 2)) Then
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　j = 1
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　Next
　　　　Next

　　　　.Value = vA
　　End With

　　Set dic = Nothing
　　Set dicC = Nothing
End Sub

Private Function mySort(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, j As Long

　　For i = LBound(vA) To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (vA(i) > vA(j)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySort = vA
End Function

Private Function mySortDesc(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, j As Long

　　For i = LBound(vA) To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (vA(i) < vA(j)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySortDesc = vA
End Function

この回答へのお礼

Samp1、Samp２を実施してみました。どちらでも一発処理でできました。有難う御座いました。
今から、頂いたcodeを一行一行で読んでみます。

お礼日時：2015/12/16 21:52

No.2 回答者： nao81818 回答日時： 2015/12/16 17:45

No.1です。

コーディングに時間かかってすみません。

以下　表の並び替えのコードです。

↓ここから
Sub 表並び替え()
Dim nRow, nCol, nCount ' カウント用変数
Dim maxRow, maxCol ' 表の最大列、最大行
Dim sheet

sheet = "Sheet1" ' シート名(適宜変更してください)

' 最大行と最大列取得
maxRow = Range("A65536").End(xlUp).Row
maxCol = Range("XFD1").End(xlToLeft).Column

' 表を行に変換
For nRow = 1 To maxRow
For nCol = 1 To maxCol
nCount = nCount + 1
Cells(maxRow + 1, nCount) = Cells(nRow, nCol)
Next nCol
Next nRow

' 並び替え実行
ActiveWorkbook.Worksheets(sheet).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sheet).Sort.SortFields.Add Key:=Range(Cells(maxRow + 1, 1), Cells(maxRow + 1, nCount)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets(sheet).Sort
.SetRange Range(Cells(maxRow + 1, 1), Cells(maxRow + 1, nCount))
.Header = xlGuess
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With

' カウント初期化
nCount = 0

' 行を表に変換
For nRow = 1 To maxRow
For nCol = 1 To maxCol
nCount = nCount + 1
Cells(nRow, nCol) = Cells(maxRow + 1, nCount)
Next nCol
Next nRow

' 並び替え用に作成した行削除
Range(Cells(maxRow + 1, 1), Cells(maxRow + 1, nCount)).Clear
End Sub
↑ここまで

ご存知かもしれませんが念のためマクロ実行方法
URL:http://kokodane.com/2010/excel2010macro_02.htm

マクロの編集で上のコード丸丸コピペして
実行してください。
編集の際に自動的に作成される
初期コードも全部消してから実行してください。

sheet = "Sheet1" ' シート名(適宜変更してください)
6行目に上記のコードがありますが、
"Sheet1"のところはその表のあるシート名を記入してください。

申し訳ないのですが、漢字はソートしたときに
思った通りの並び順にならないかもしれません。
希望がありましたら、言ってください。
なんとかならないか試してみます。
漢字・記号以外の並び替えはちゃんとできます。

私はExcel2007では動作確認しましたが、
もしかしたら2010ではエラーが出てしまうかも
しれませんので、上手く行きませんでしたら
言ってください。直します。

No.1 回答者： nao81818 回答日時： 2015/12/16 14:52

3つお伺いしたい点があります。

1. 回答はマクロでも良いですか？

2. 実際に並び替えを行いたい表の
データ数はどのくらいなのですか？

3. 質問者様のExcelは2003以前か2007以降か
教えてください。
行で並び替えを行いたいようなので、データ量が多く
2003以前であるなら、私もやりかた分からないかもです...。

この回答へのお礼

早速の返事、誠にありがとうございました。
１　マクロでも、他の手段でも大丈夫です。
２　多くないです。セル数から言うと、何十個程度です。
３　excel 2010です。

是非、よろしくお願いします。

お礼日時：2015/12/16 15:08