| |
試しに、61503行（内20000行がKeyで重複）のデータを作って
Win98、Excel2000にて提示のコードを使って実行しましたが
確かに、処理が非常に遅いのか？、フリーズした状態なのか？
不安定な状態の様でした
其処で、以下のコードを試しに作って見ました
結果は、合って居ると思いますが確認して下さい
尚、データに列見出しは無い物とし、List先頭はA1から始まる物とします
Option Explicit
Public Sub Ver2maedaosi_2()
'Listのデータ列数（A列〜D列）
Const clngColumns As Long = 4
'「計画数」列の在る位置(品番列を0番目と勘定する)
Const clngItems As Long = 2
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntTop As Variant
Dim vntData As Variant
Dim vntItems As Variant
Dim vntKeys As Variant
Dim vntOrders As Variant
Dim vntDelete As Variant
Dim lngStart As Long
Dim lngCount As Long
Dim lngMax As Long
Dim strProm As String
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("展開").Range("A1")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'復帰用整列Keyを作成
With rngList.Offset(, clngColumns)
.Value = 1
.Resize(lngRows).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Trend:=False
End With
'整列Keyを作成（A列順のB列順）
vntKeys = Array(0, 1)
'整列順を指定
lngMax = UBound(vntKeys)
ReDim vntOrders(lngMax)
For i = 0 To lngMax
vntOrders(i) = xlAscending
Next i
'データをKeys順に整列
DataSort rngList.Resize(lngRows, clngColumns + 1), vntKeys, vntOrders
With rngList
'復帰用整列Keyを取得
vntDelete = .Offset(, clngColumns).Resize(lngRows + 1).Value
'「計画数」列の値を配列に取得
vntItems = .Offset(, clngItems).Resize(lngRows + 1).Value
End With
'Listの先頭〜最終まで繰り返し
lngStart = 0
vntTop = rngList.Offset(lngStart).Resize(, clngColumns).Value
For i = 1 To lngRows
'Listから1レコード分取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'配列の先頭から最終まで比較
For j = 0 To lngMax
If vntTop(1, vntKeys(j) + 1) <> vntData(1, vntKeys(j) + 1) Then
Exit For
End If
Next j
'前列一致した場合
If j > lngMax Then
'「計画数」列の集計
vntItems(lngStart + 1, 1) _
= vntItems(lngStart + 1, 1) + vntData(1, clngItems + 1)
'Flagを立てる
vntDelete(i + 1, 1) = Empty
'削除数を加算
lngCount = lngCount + 1
Else
'同値先頭位置を更新
lngStart = i
'配列の中身を入れ替え
vntTop = vntData
End If
Next i
With rngList
'「計画数」列の集計を出力
.Offset(, clngItems).Resize(lngRows).Value = vntItems
'Flagを最終列に出力
.Offset(, clngColumns).Resize(lngRows).Value = vntDelete
'削除行を最終行に集める為、Flag列をKeyとして整列
DataSort .Resize(lngRows, clngColumns + 1), _
Array(clngColumns), Array(xlAscending)
'削除行が有るなら
If lngCount > 0 Then
'削除行を削除
.Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
strProm = lngCount & "件の削除が実行されました"
Else
strProm = "該当行が無い為、削除は行われませんでした"
End If
'削除Flag列を削除
.Offset(, clngColumns).EntireColumn.Delete
'列幅の調整
.Parent.Columns.AutoFit
End With
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
' Sheets("メニュー画面").Select 'メニュー画面を選ぶ
MsgBox strProm , vbInformation
End Sub
Private Sub DataSort(rngScope As Range, _
vntKeys As Variant, _
vntOrders As Variant)
Dim i As Long
Dim j As Long
Dim vntK As Variant
Dim vntO As Variant
Dim lngNum As Long
vntK = vntKeys
vntO = vntOrders
lngNum = -Int(-(UBound(vntK) + 1) / 3) * 3 - 1
ReDim Preserve vntK(lngNum), vntO(lngNum)
For i = UBound(vntOrders) + 1 To lngNum
vntO(i) = xlAscending
Next i
With rngScope
For i = lngNum To 0 Step -3
.Sort _
Key1:=.Cells(1, vntK(i - 2) + 1), _
Key2:=IIf(IsEmpty(vntK(i - 1)), vntK(i - 1), .Cells(1, vntK(i - 1) + 1)), _
Key3:=IIf(IsEmpty(vntK(i)), vntK(i), .Cells(1, vntK(i) + 1)), _
Order1:=vntO(i - 2), _
Order2:=vntO(i - 1), _
Order3:=vntO(i), _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
Next i
End With
End Sub
|
|
Hirofumi
- 10/1/31(日) 9:13 -
