Excel VBA質問箱 IV

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

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


7385 / 13645 ツリー ←次へ | 前へ→

【39450】処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 10:34 質問[未読]
【39453】Re:処理速度アップの方法は無いですか てっちゃん 06/6/24(土) 13:42 回答[未読]
【39454】Re:処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 13:58 お礼[未読]
【39455】Re:処理速度アップの方法は無いですか Kein 06/6/24(土) 14:10 回答[未読]
【39456】Re:処理速度アップの方法は無いですか Hirofumi 06/6/24(土) 14:14 回答[未読]
【39457】Re:処理速度アップの方法は無いですか Hirofumi 06/6/24(土) 14:20 回答[未読]
【39462】Re:処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 15:28 お礼[未読]
【39473】Re:処理速度アップの方法は無いですか Hirofumi 06/6/24(土) 18:59 回答[未読]
【39475】Re:処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 19:53 お礼[未読]

【39450】処理速度アップの方法は無いですか
質問  勉強中です E-MAIL  - 06/6/24(土) 10:34 -

引用なし
パスワード
   おはよう御座います。
今回は検索条件に合ったものを行ごと削除してC列でソートを掛けるという
事をしております。
前回(39281)でJakaさんに教えていただいた
物に自分なりにいろいろとやってみまして機能していますが
データー数が10000件を超えてしまう為、処理の時間が
かかってしまいます。
現在テストで検索条件2900行 検索範囲5250行でやっていますが
約6分ほど掛かります。他にいい方法かヒントになるレスを教えてください。

対象マスターのシートのAには重複はありません。

    A       B      C  ・・・・・J

1  Jコード   (空白です)  分類コード   Tコード 





発注商品のシートのA列には重複はありません

     A    B     C
1  Jコード   品名    Tコード





というようなシートで以下のように書いています。

Sub Test()


Sheets("対象マスター").Select
  Rows("1:1").Select
  Selection.Insert Shift:=xlDown

Dim SachRag As Range, FilTRg As Range, Cel As Range, Chek As Variant
With Sheets("発注商品")
  Set SachRag = .Range(.Range("A2"), .Range("A65536").End(xlUp))
End With
With Sheets("対象マスター")
  Set FilTRg = .Range(.Range("A2"), .Range("A65536").End(xlUp))
End With
Application.ScreenUpdating = False
For Each Cel In SachRag
  Chek = Application.Match(Cel.Value, FilTRg, 0)
  If Not IsError(Chek) Then
    FilTRg.AutoFilter Field:=1, Criteria1:=Cel.Value
    FilTRg.Offset(1).Resize(FilTRg.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
    Sheets("対象マスター").ShowAllData
    DoEvents
  End If
Next
Sheets("対象マスター").AutoFilterMode = False
 
  Sheets("対象マスター").Select
  Rows("1:1").Select
  Selection.Delete Shift:=xlUp
Range("C1").Select
  ActiveCell.FormulaR1C1 = "0000"

Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
    :=xlPinYin, DataOption1:=xlSortTextAsNumbers

Range("C1").Select
  ActiveCell.FormulaR1C1 = "分類コード"

Application.ScreenUpdating = True
End Sub

Jakaさんのをそのままですので恥ずかしいのですが・・・
何かヒントがありましたらお願いします。
環境は XPホーム EXCEL2003 メモリーは512MB プロフェサーは
x86 Family 6 Model 13 Stepping 8 GenuineIntel "1496 Mhzです。

【39453】Re:処理速度アップの方法は無いですか
回答  てっちゃん  - 06/6/24(土) 13:42 -

引用なし
パスワード
   ▼勉強中です さん:
こんにちは

「対象マスター」シートと「発注商品」シートのJコードを見て、
一致するものを、対象マスターシートから削除し、
次に、対象マスターシートを分類コード順に並び替える、
という処理で良いですか?

良いという前提で回答します。


1.「対象マスター」(表内)に1列挿入します。
  例えばA列とB列の間に挿入するとします。

2.B列に式を挿入します。
  =IF(ISERROR(VLOOKUP(A2,発注商品!$A$2:$A$65536,1,FALSE)),0,-1)

  「発注商品!$A$2:$A$65536」等の行数は、適宜取得して変更してください。
  A:Aでも良いですが、取得して範囲を設定したほうが処理速度は速いと思います。

2-補.件数が少ない場合は、このままでも良いですが、件数が多い場合は、
  B列の式(VLOOKUP)を外した方が、処理速度はより向上するかと思います。
  (コピー→形式を選択して貼り付け→値(→Esc))

3.B列で並べ替えをします。
  オリジナルのB列が空白なので、範囲の取得に注意して下さい。


4.SUM(B2:B65536)を求めます。
  3で並べ替えをした際の、-1、すなわち削除対象の行数が分かります。

5.対象行を削除します。

6.挿入した列(B列)を削除します。

7.C列(分類コード)で並べ替えをします。
  B列(空白?)があるようなので、範囲の取得に注意。


以上のステップでコードを作成すると、現在のものよりは処理速度は上がると思います。

簡単な解説を入れると、1行ずつフィルター/削除していたものを、
削除用フラグを付けて、一度に削除する、という処理にしてみました。


最初の前提が違ったら、ゴミレスです。無視してください。

【39454】Re:処理速度アップの方法は無いですか
お礼  勉強中です E-MAIL  - 06/6/24(土) 13:58 -

引用なし
パスワード
   てっちゃんさん
こんにちは、
レスありがとうございます。
早速試してみます。結果ご報告いたします。

【39455】Re:処理速度アップの方法は無いですか
回答  Kein  - 06/6/24(土) 14:10 -

引用なし
パスワード
   対象マスターの方は、項目行があるのかないのかはっきりしませんので、
仮にあったとして A2 からデータが入力されている、という前提で

Sub Test2()
  Dim Sh As Worksheet, Sh2 As Worksheet
  Dim C As Range
  Dim Ck As Variant

  Set Sh = Worksheets("対象マスター")
  Set Sh2 = Worksheets("発注商品")
  Application.ScreenUpdating = False
  Sh.Range("K1").Value = "CheckNum"
  For Each C In Sh2.Range("A2", Sh2.Range("A65536").End(xlUp))
   Ck = Application.Match(C.Value, Sh.Range("A:A"), 0)
   If Not IsError(Ck) Then Sh.Cells(Ck, 11).Value = 1
  Next
  Sh.Range("A1", Sh.Range("A65536").End(xlUp)).Resize(, 11) _
  .Sort Key1:=Sh.Range("K1"), Order1:=xlAscending, _
  Header:=xlYes, Orientation:=xlSortColumns
  Sh.Range("K2", Sh.Range("K65536").End(xlUp)) _
  .EntireRow.Delete xlShiftUp
  Sh.Range("K1").ClearContents
 
  ここへ Sh の表範囲をC列をキーにして並べ替えるコードを入れる

  Application.ScreenUpdating = True
End Sub

【39456】Re:処理速度アップの方法は無いですか
回答  Hirofumi  - 06/6/24(土) 14:14 -

引用なし
パスワード
   '"対象マスター"のA列と"発注商品"のA列を比較して、同じ物が有ったら
'"発注商品"の其の行を削除すると言う事で善いのかな?

Option Explicit

Public Sub DataMatch()

'  検索条件に合ったものを行ごと削除

  '"対象マスター"のデータ列数(A列〜J列の10列)
  Const clngColumns1 As Long = 10
  '"対象マスター"の比較Key列位置(基準からのA列「Jコード」列Offset値)
  Const clngKeys1 As Long = 0
  '"発注商品"のデータ列数(A列〜C列の3列)
  Const clngColumns2 As Long = 3
  '"発注商品"の比較Key列位置(基準からのA列「Jコード」の列Offset値)
  Const clngKeys2 As Long = 0
  '"発注商品"の最終整列Key列(C列)
  Const clngSort As Long = 2
  
  Dim i As Long
  Dim rngList1 As Range
  Dim lngEnd1 As Long
  Dim vntData1 As Variant
  Dim lngRow1 As Long
  Dim rngList2 As Range
  Dim lngEnd2 As Long
  Dim vntData2 As Variant
  Dim lngRow2 As Long
  Dim lngDelete() As Long
  Dim lngCount As Long
  Dim strProm As String

  '"対象マスター"データのA1を基準とします(列見出しのセル位置)
  Set rngList1 = Worksheets("対象マスター").Cells(1, "C")
  
  '"発注商品"データのA1を基準とする(列見出しのセル位置)
  Set rngList2 = Worksheets("発注商品").Cells(1, "A")
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  '"対象マスター"データの基準に就いて基礎データの取得
  If Not GetBasicData(rngList1, lngEnd1, clngColumns1, clngKeys1, vntData1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  '"発注商品"データの基準に就いて基礎データの取得
  If Not GetBasicData(rngList2, lngEnd2, clngColumns2, clngKeys2, vntData2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  '削除Flagの配列を確保
  ReDim lngDelete(1 To lngEnd2, 1 To 1)
  
  '"対象マスター"の比較位置
  lngRow1 = 1
  '"発注商品"の比較位置
  lngRow2 = 1
  '"対象マスター"若しくは、"発注商品"が最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '比較結果に就いて
    Select Case vntData1(lngRow1, 1)
      Case Is = vntData2(lngRow2, 1) 'Matchiした場合
        '削除Flagを立てる
        lngDelete(lngRow2, 1) = 1
        '削除数をカウント
        lngCount = lngCount + 1
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntData2(lngRow2, 1) '"発注商品"固有値の場合
        '"発注商品"の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntData2(lngRow2, 1) '"対象マスター"固有値の場合
        '"対象マスター"の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop

  '"対象マスター"データの復旧
  With rngList1
    '元データ順位を復帰
    .Offset(1).Resize(lngEnd1, clngColumns1 + 1).Sort _
        Key1:=.Offset(1, clngColumns1), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke

    '復帰用Key列を削除
    .Offset(, clngColumns1).EntireColumn.Delete
  End With
  
  With rngList2
    '削除Flagの配列を出力
    .Offset(1, clngColumns2 + 1) _
          .Resize(lngEnd2).Value = lngDelete
    '削除Flag列順のC列順で整列
    .Offset(1).Resize(lngEnd2, clngColumns2 + 2).Sort _
        Key1:=.Offset(1, clngColumns2 + 1), Order1:=xlAscending, _
        Key2:=.Offset(1, clngSort), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '削除データが有るなら
    If lngCount > 0 Then
      '行削除
      .Offset(lngEnd2 - lngCount + 1) _
            .Resize(lngCount).EntireRow.Delete
      strProm = lngCount & "件の削除が完了しました"
    Else
      strProm = "削除行が有りません"
    End If
    '復帰用Key列を削除
    .Offset(, clngColumns2).Resize(, 2).EntireColumn.Delete
  End With
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
    
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                lngKeys As Long, _
                vntData As Variant) As Boolean

  Dim i As Long
  Dim lngNumb() As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(65536 - .Row, lngKeys).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows < 0 Then
      Exit Function
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データをlngKeys列で整列
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
        Key1:=.Offset(1, lngKeys), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'データを配列に取得
    vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
  End With
  
  GetBasicData = True

End Function

【39457】Re:処理速度アップの方法は無いですか
回答  Hirofumi  - 06/6/24(土) 14:20 -

引用なし
パスワード
   'もし、逆に、"対象マスター"の其の行を削除すると言う事なら以下の様に修正してください

  '"発注商品"のデータ列数(A列〜C列の3列)
  Const clngColumns1 As Long = 3
  '"発注商品"の比較Key列位置(基準からのA列「Jコード」の列Offset値)
  Const clngKeys1 As Long = 0
  '"対象マスター"のデータ列数(A列〜J列の10列)
  Const clngColumns2 As Long = 10
  '"対象マスター"の比較Key列位置(基準からのA列「Jコード」列Offset値)
  Const clngKeys2 As Long = 0
  '"対象マスター"の最終整列Key列(C列)
  Const clngSort As Long = 2

【39462】Re:処理速度アップの方法は無いですか
お礼  勉強中です E-MAIL  - 06/6/24(土) 15:28 -

引用なし
パスワード
   てっちゃんさん Keinさん Hirofumiさん
ありがとうございます。
驚きを通りこして 感動するほど早い!!!
なぜ?はこれから中身を検証していきたいです。
Hirofumiさんのは、削除なしのMsgが出ましたのでこれは・・
勉強の意味でも自分で何とかして見ます。
(Hirofumiさんごめんなさい)
やはり紙に図を書いて作っているようじゃまだまだですね 反省...

ありがとうございました。また壁にぶつかった際は
よろしくお願いいたします。

【39473】Re:処理速度アップの方法は無いですか
回答  Hirofumi  - 06/6/24(土) 18:59 -

引用なし
パスワード
   もう見て居ないかな?
ゴメン、Listの指定位置が間違っていました

  '"対象マスター"データのA1を基準とします(列見出しのセル位置)
  Set rngList1 = Worksheets("対象マスター").Cells(1, "C")



  '"対象マスター"データのA1を基準とします(列見出しのセル位置)
  Set rngList1 = Worksheets("対象マスター").Cells(1, "A")

とします、詰まり.Cells(1, "C")が.Cells(1, "A")と成ります

また、削除するシートの指定の部分も、シートを指定する変更部分がたりませんでした

 'もし、逆に、"対象マスター"の其の行を削除すると言う事なら以下の様に修正してください

  '"発注商品"のデータ列数(A列〜C列の3列)
  Const clngColumns1 As Long = 3
  '"発注商品"の比較Key列位置(基準からのA列「Jコード」の列Offset値)
  Const clngKeys1 As Long = 0
  '"対象マスター"のデータ列数(A列〜J列の10列)
  Const clngColumns2 As Long = 10
  '"対象マスター"の比較Key列位置(基準からのA列「Jコード」列Offset値)
  Const clngKeys2 As Long = 0
  '"対象マスター"の最終整列Key列(C列)
  Const clngSort As Long = 2

  '"対象マスター"データのA1を基準とします(列見出しのセル位置)
  Set rngList1 = Worksheets("発注商品").Cells(1, "A")
  
  '"発注商品"データのA1を基準とする(列見出しのセル位置)
  Set rngList2 = Worksheets("対象マスター").Cells(1, "A")
  


【39475】Re:処理速度アップの方法は無いですか
お礼  勉強中です E-MAIL  - 06/6/24(土) 19:53 -

引用なし
パスワード
   Hirofumiさん こんばんは

もちろん見てますよーというよりメールが来るので
必ずチェックしています

修正の箇所は今日の夜にじっくり見ようと思っていましたので
ありがとう御座います。 皆さん本当にやさしい方ばかりで
とても感動しています。今後もよろしくお願いします。

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