| |
Option Explicit
Public Sub Sample()
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntData As Variant
Dim vntKeys As Variant
Dim strProm As String
'項目の頭文字を並べる順番に列挙(空白以外は*を付けて)
vntKeys = Array("N*", "品*", "S*", "", "数*")
With ActiveSheet.UsedRange
If .Columns.Count = 1 Then
strProm = "データが有りません"
GoTo Wayout
End If
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = .Item(1, 1)
'列数取得
lngColumns = .Columns.Count
If lngColumns < UBound(vntKeys) + 1 Then
lngColumns = UBound(vntKeys) + 1
End If
'行数取得
lngRows = .Rows.Count - 1
End With
'列見出しを配列に取得
vntData = rngList.Resize(, lngColumns + 1).Value
'項目の順位を取得
For i = 1 To lngColumns
For j = 0 To UBound(vntKeys)
If vntData(1, i) Like vntKeys(j) Then
Exit For
End If
Next j
vntData(1, i) = j
Next i
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'データ最終行の下に順位Keyを出力
.Offset(lngRows + 1).Resize(, lngColumns).Value = vntData
'順位順に整列
DataSort rngList.Resize(lngRows + 2, lngColumns), _
.Offset(lngRows + 1), xlAscending, xlLeftToRight
'順位Keyを削除
.Offset(lngRows + 1).EntireRow.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngSortOrder As Long = xlAscending, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=lngSortOrder, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|
Hirofumi
- 09/11/6(金) 13:40 -
