| |
こんばんは。
>当初はＢ列に都道府県名を取り出し、質問のArray関数を利用していましたが
>一度に行う方法はないかと思っています。
Ｂ列を作業領域として、キーを配置し、これを基にソートする・・、
これが一番簡単だと思いますし、Excelを使うならこの方法を使わないと
勿体無いですよ！！
とお断りした上で・・・、この作業領域を別の場所に置く方法です。
標準モジュールに
'================================================================
Sub main()
Dim g0 As Long
Dim myarray As Variant
Call sort_set_list(Array("北海道", "青森県", _
"岩手県", "宮城県", "秋田県", "山形県", "福島県", "茨城県", _
"栃木県", "群馬県", "埼玉県", "千葉県", "東京都", "神奈川", _
"新潟県", "富山県", "石川県", "福井県", "山梨県", "長野県", _
"岐阜県", "静岡県", "愛知県", "三重県", "滋賀県", "京都府", _
"大阪府", "兵庫県", "奈良県", "和歌山", "鳥取県", "島根県", _
"岡山県", "広島県", "山口県", "徳島県", "香川県", "愛媛県", _
"高知県", "福岡県", "佐賀県", "長崎県", "熊本県", "大分県", _
"宮崎県", "鹿児島", "沖縄県"))
g0 = 1
Do Until Cells(g0, 1).Value = ""
Call sort_put_ele(Left(Cells(g0, 1).Value, 3), Cells(g0, 1).Value)
g0 = g0 + 1
Loop
g0 = 1
myarray = sort_get_array(True)
Do While TypeName(myarray) <> "Boolean"
Range(Cells(g0, 1), Cells(g0 + UBound(myarray) - 1, 1)).Value = _
Application.Transpose(myarray)
g0 = g0 + UBound(myarray)
myarray = sort_get_array()
Loop
Call sort_term
End Sub
別の標準モジュールに
'===================================================================
Option Explicit
Private sdic As object
'===================================================================
Sub sort_set_list(myarray As Variant)
Dim sitem() As Variant
Dim g0 As Long
Set sdic = CreateObject("scripting.dictionary")
For g0 = LBound(myarray) To UBound(myarray)
sdic.Add myarray(g0), sitem()
Next
End Sub
'===================================================================
Sub sort_put_ele(skey As Variant, sdata As Variant)
Dim idx As Long
Dim sarray As Variant
If sdic.Exists(skey) Then
sarray = sdic.Item(skey)
On Error Resume Next
idx = UBound(sarray) + 1
If Err.Number <> 0 Then idx = 1
ReDim Preserve sarray(1 To idx)
sarray(idx) = sdata
sdic.Item(skey) = sarray
On Error GoTo 0
End If
End Sub
'===================================================================
Function sort_get_array(Optional stt As Boolean = False) As Variant
Static sidx As Long
Static skey As Variant
Dim wk As Long
If stt Then
skey = sdic.Keys
sidx = LBound(skey)
End If
On Error Resume Next
sort_get_array = False
Do While sidx <= UBound(skey)
sort_get_array = sdic.Item(skey(sidx))
sidx = sidx + 1
Err.Clear
wk = UBound(sort_get_array)
If Err.Number <> 0 Then
sort_get_array = False
Else
Exit Do
End If
Loop
On Error GoTo 0
End Function
'===================================================================
Sub sort_term()
Set sdic = Nothing
End Sub
として、対象シートをアクティブにしてmainを実行してください。
尚、データはセルＡ１から入っているとします。
|
|
ichinose
- 07/3/4(日) 17:16 -
