Excel VBA質問箱 IV

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

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


20257 / 76732 ←次へ | 前へ→

【61897】Re:消去作業について
発言  Hirofumi  - 09/6/11(木) 10:42 -

引用なし
パスワード
   試しにこんな事して見ると効果の具合が解ると思います

コードの始まりと終わりで時刻を取って、その差をMsgBoxで表示します
削除対象のデータを同じ物を用意して下さい


先ず、Upされたコードで

Public Sub Test()

  Dim j As Long
  Dim sngTime1 As Single
  Dim sngTime2 As Single
  
  sngTime2 = Timer
    
  For j = 800 To 1 Step -1
    If Worksheets("D1").Cells(j + 2, 130) = "" Or Worksheets("D1").Cells(j + 2, 1) < 50 Then
      Worksheets("D1").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D2").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D3").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D4").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D5").Rows(j + 2).Delete SHIFT:=xlUp
      Worksheets("D6").Rows(j).Delete SHIFT:=xlUp
    End If
  Next j

  sngTime1 = Timer

  MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
  
End Sub

次に、回答したコードで

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long    'データ行数
  Dim lngCount As Long   '削除数
  Dim vntSheets As Variant '対象シート名の一覧
  Dim vntTop As Variant   '対象シートのデータ先頭行
  Dim vntColumns As Variant '対象シートの最終データ列位置
  Dim lngDelete() As Long   '削除行のFlag
  Dim vntKeys1 As Variant
  Dim vntKeys2 As Variant
  
  Dim sngTime1 As Single
  Dim sngTime2 As Single
  
  sngTime2 = Timer
  
  vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
  vntTop = Array(3, 3, 3, 3, 3, 1)
  vntColumns = Array(130, 130, 130, 130, 130, 130)
  
  lngRows = 800
  
  'D1シートに就いて
  With Worksheets(vntSheets(0))
    '130列のデータを配列に取得
    vntKeys1 = .Range(.Cells(vntTop(0), 130), _
            .Cells(vntTop(0) + lngRows - 1, 130)).Value
    '1列のデータを配列に取得
    vntKeys2 = .Range(.Cells(vntTop(0), 1), _
            .Cells(vntTop(0) + lngRows - 1, 1)).Value
  End With
  '削除Flag用の配列を確保
  ReDim lngDelete(1 To lngRows, 1 To 1)
  
  '削除Flagを作成
  For i = 1 To lngRows
    If vntKeys1(i, 1) = "" Or vntKeys2(i, 1) < 50 Then
      lngDelete(i, 1) = 1
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False '★追加
    
  '削除する行が在るなら
  If lngCount > 0 Then
    'シート一覧に基いて
    For i = 0 To UBound(vntSheets)
      With Worksheets(vntSheets(i))
        '最終列の後ろに削除Flagを出力
        .Cells(vntTop(i), vntColumns(i) + 1).Resize(lngRows).Value = lngDelete
        '削除FlagをKeyとしてListを整列
        .Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
            key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '削除Flagが1の行を削除
        .Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
        '削除Flagを削除
        .Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
      End With
    Next i
  End If
  
  '画面更新を再開
  Application.ScreenUpdating = True '★追加

  sngTime1 = Timer

  MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
  
End Sub

次に、回答したコードから、Key1、Key2、削除FlagのlngDeleteを廃し、
直接セルに対する読み書きに変更した物

Public Sub Sample_3()

'  配列変数を使用しない

  Dim i As Long
  Dim j As Long
  Dim lngRows As Long    'データ行数
  Dim lngCount As Long   '削除数
  Dim vntSheets As Variant '対象シート名の一覧
  Dim vntTop As Variant   '対象シートのデータ先頭行
  Dim vntColumns As Variant '対象シートの最終データ列位置
  
  Dim sngTime1 As Single
  Dim sngTime2 As Single
  
  sngTime2 = Timer
  
  vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
  vntTop = Array(3, 3, 3, 3, 3, 1)
  vntColumns = Array(130, 130, 130, 130, 130, 130)
  
  lngRows = 800
  
  '削除Flagを作成
  For i = 1 To lngRows
    '条件に合わない物に印を付ける
    If Not (Worksheets(vntSheets(0)).Cells(vntTop(0) + i - 1, 130).Value = "" _
        Or Worksheets(vntSheets(0)).Cells(vntTop(0) + i - 1, 1).Value < 50) Then
      For j = 0 To UBound(vntSheets)
        Worksheets(vntSheets(j)).Cells(vntTop(j) + i - 1, vntColumns(j) + 1).Value = "*"
      Next j
    Else
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False '★追加
    
  '削除する行が在るなら
  If lngCount > 0 Then
    'シート一覧に基いて
    For i = 0 To UBound(vntSheets)
      With Worksheets(vntSheets(i))
        '削除FlagをKeyとしてListを整列
        .Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
            key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, SortMethod:=xlStroke
        '削除Flagが1の行を削除
        .Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
        '削除Flagを削除
        .Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
      End With
    Next i
  End If
  
  '画面更新を再開
  Application.ScreenUpdating = True '★追加

  sngTime1 = Timer

  MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
  
End Sub

私の機器では、
元々のコードで:約 7.44秒
回答のコードで:約 0.32秒
廃したコードで:約 0.42秒

800行程度ですので、余り差は無い様ですが配列変数を使った方が効果は有ります
0 hits

【61871】消去作業について YOUSUKE 09/6/10(水) 1:05 質問
【61873】Re:消去作業について Hirofumi 09/6/10(水) 8:09 発言
【61876】Re:消去作業について Hirofumi 09/6/10(水) 9:47 回答
【61882】Re:消去作業について YOUSUKE 09/6/10(水) 13:51 お礼
【61895】Re:消去作業について YOUSUKE 09/6/11(木) 8:07 お礼
【61896】Re:消去作業について Hirofumi 09/6/11(木) 8:50 回答
【61897】Re:消去作業について Hirofumi 09/6/11(木) 10:42 発言
【61900】Re:消去作業について YOUSUKE 09/6/11(木) 14:13 お礼

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