|
先頭行に列見出しが有る物とします
Option Explicit
Public Sub Sample()
'データ列数を設定(例えばA列〜O列で15列)
Const clngColumns As Long = 15
'日付の有る列位置を設定(基準セル位置のA列からの列Offset:C列)
Const clngDate As Long = 2
'D列の列位置を設定(基準セル位置のA列からの列Offset:D列)
Const clngKey As Long = 3
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim strProm As String
'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
Set rngList = ActiveSheet.Cells(1, "A")
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'データ行数を取得
lngRows = .Offset(Rows.Count - .Row, clngDate).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'日付データを配列に取得
vntData = .Offset(1, clngDate).Resize(lngRows + 1).Value
End With
'日付の行位置を取得
For i = lngRows - 1 To 1 Step -1
If vntData(lngRows, 1) <> vntData(i, 1) Then
Exit For
End If
Next i
'データを整列
With rngList
If lngRows - i > 0 Then
.Offset(i + 1).Resize(lngRows - i, clngColumns).Sort _
Key1:=.Offset(i + 1, clngKey), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlCodePage
End If
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|