Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


17839 / 76732 ←次へ | 前へ→

【64341】Re:処理が重い
回答  Hirofumi  - 10/1/31(日) 9:13 -

引用なし
パスワード
   試しに、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

0 hits

【64329】処理が重い tetu 10/1/30(土) 18:26 質問
【64330】Re:処理が重い かみちゃん 10/1/30(土) 18:32 発言
【64376】Re:処理が重い tetu 10/1/31(日) 23:18 お礼
【64331】Re:処理が重い Hirofumi 10/1/30(土) 20:07 発言
【64335】Re:処理が重い Hirofumi 10/1/31(日) 0:26 発言
【64337】Re:処理が重い tetu 10/1/31(日) 2:32 発言
【64341】Re:処理が重い Hirofumi 10/1/31(日) 9:13 回答
【64344】Re:処理が重い Hirofumi 10/1/31(日) 9:44 発言
【64377】Re:処理が重い tetu 10/1/31(日) 23:27 質問
【64379】Re:処理が重い Hirofumi 10/2/1(月) 8:03 回答
【64411】Re:処理が重い tetu 10/2/4(木) 1:56 質問
【64416】Re:処理が重い Hirofumi 10/2/4(木) 11:54 回答
【64471】Re:処理が重い tetu 10/2/11(木) 1:12 質問
【64473】Re:処理が重い Hirofumi 10/2/11(木) 9:49 回答
【64372】Re:処理が重い よろずや 10/1/31(日) 20:55 発言
【64378】Re:処理が重い tetu 10/1/31(日) 23:29 お礼
【64380】Re:処理が重い Jaka 10/2/1(月) 9:19 発言
【64412】Re:処理が重い tetu 10/2/4(木) 2:00 お礼
【64413】Re:処理が重い かみちゃん 10/2/4(木) 6:25 発言
【64470】Re:処理が重い tetu 10/2/11(木) 0:23 お礼

17839 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free