| |
もう少し処理速度を上げるにはこんなかな？
Option Explicit
Public Sub Sample2()
'◆データ列数（A列のみ）
Const clngColumns As Long = 1
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim lngNumb() As Long
Dim lngTop As Long
Dim lngCount As Long
Dim lngCalculation As Long
Dim strProm As String
'◆Listの先頭セル位置を基準とする
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'列データを配列に取得
vntData = .Resize(lngRows + 1).Value
'整列Keyを保存する配列を確保
ReDim lngNumb(1 To lngRows + 1, 1 To 1)
End With
With Application
'画面更新を停止
.ScreenUpdating = False
'再計算モードを保存
lngCalculation = .Calculation
'再計算モードを手動に設定
.Calculation = xlCalculationManual
End With
With rngList
'同一値の行数を初期値に
lngCount = 1
For i = 2 To lngRows + 1
If vntData(i, 1) <> vntData(i - 1, 1) Then
'整列Key値を更新
lngNumb(i, 1) = lngNumb(i - 1, 1) + 1
'最終行の下に数式を出力
.Offset(lngRows).FormulaR1C1 = "=Sum(R[-" & (lngCount) & "]C:R[-1]C)"
'整列Keyを出力
.Offset(lngRows, clngColumns).Value = lngNumb(i, 1) - 1
lngRows = lngRows + 1
'先頭行位置を保存
lngTop = i - 1
'同一値の行数を初期値に
lngCount = 1
Else
'同一値の行数を更新
lngCount = lngCount + 1
'整列Key値を代入
lngNumb(i, 1) = lngNumb(i - 1, 1)
End If
Next i
'整列Keyを出力
.Offset(, clngColumns).Resize(UBound(lngNumb, 1) - 1).Value = lngNumb
'整列Keyで行整列
DataSort .Resize(lngRows, clngColumns + 1), .Offset(, clngColumns)
'整列Keyを削除
.Offset(, clngColumns).EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
With Application
'再計算モードを元に戻す
.Calculation = lngCalculation
'再計算実行
.Calculate
'画面更新を再開
.ScreenUpdating = True
End With
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
|
|
Hirofumi
- 08/11/29(土) 11:46 -
