エクセルVBAにてご教授をお願い致します。 下記条件一致処理にてDictionaryを用い書きました。 十分速いのですがもっと早くしたいです。

エクセルVBAにてご教授をお願い致します。 下記条件一致処理にてDictionaryを用い書きました。 十分速いのですがもっと早くしたいです。 ネットで調べたところセルへの記載ではなくDictionaryから取り出す のに時間がかかるようですが以下記述でいくとどのようにすればよろしいでしょうか? 詳しい方、教えて下さい。 Sub test() Dim i As Long, dic As Object Set dic = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'Dictionary取込--------------------------- With Sheets("Sheet2") For i = 2 To .Cells(Rows.Count, 3).End(xlUp).Row If Not dic.exists(Cells(i, 3).Value) Then dic(.Cells(i, 3).Value) = Array(.Cells(i, 2), .Cells(i, 4)) End If Next End With '書き出し----------------------------------- With Sheets("Sheet1") On Error Resume Next For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row .Cells(i, 5) = dic(.Cells(i, 2).Value)(0) .Cells(i, 7) = dic(.Cells(i, 2).Value)(1) Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Set dic = Nothing End Sub

Excel | Visual Basic43閲覧xmlns="http://www.w3.org/2000/svg">50

ベストアンサー

0

遅いとしたらDictionaryが遅いのではなくセルの読み書きが遅いだけです。 特にセルの書き込みは大きさではなく1回ごとが遅いので回数を減らすと速度アップします。 配列を使い、セルの読み書きを1列1回に減らしています。 Sub test() Dim dic As Object Dim ws As Worksheet Dim lastRow As Long Dim i As Long Set dic = CreateObject("Scripting.Dictionary") 'Dictionary取込--------------------------- Dim c2 As Variant Dim c3 As Variant Dim c4 As Variant Set ws = Sheets("Sheet2") lastRow = ws.Cells(Rows.Count, 3).End(xlUp).Row c2 = ws.Cells(1, 2).Resize(lastRow).Value c3 = ws.Cells(1, 3).Resize(lastRow).Value c4 = ws.Cells(1, 4).Resize(lastRow).Value For i = 2 To lastRow If Not dic.exists(c3(i, 1)) Then dic(c3(i, 1)) = Array(c2(i, 1), c4(i, 1)) End If Next '書き出し----------------------------------- Dim c5 As Variant Dim c7 As Variant Set ws = Sheets("Sheet1") lastRow = ws.Cells(Rows.Count, 2).End(xlUp).Row c2 = ws.Cells(1, 2).Resize(lastRow).Value ReDim c5(1 To lastRow, 1 To 1) ReDim c7(1 To lastRow, 1 To 1) c5(1, 1) = ws.Cells(1, 5) c7(1, 1) = ws.Cells(1, 7) For i = 2 To lastRow If dic.exists(c2(i, 1)) Then c5(i, 1) = dic(c2(i, 1))(0) c7(i, 1) = dic(c2(i, 1))(1) End If Next ws.Cells(1, 5).Resize(lastRow, 1).Value = c5 ws.Cells(1, 7).Resize(lastRow).Value = c7 End Sub 質問のプログラムの中で >If Not dic.exists(Cells(i, 3).Value) Then でCellsの前にドットが無いです。 あと書き込むときにdic.existsで要素をチェックしてないので追加しました。 それでOnErrorが必要なのかもしれないけれど。

その他の回答(2件)

0

dic.itemsの配列に入れているのがオブジェクトなので情報量が数十倍になっているのかと思います。 dic(.Cells(i, 3).Value) = Array(.Cells(i, 2).Value, .Cells(i, 4).Value) としただけでも随分違うと考えますが? 下記では配列のインデックスだけをdicに収納 Sub test() Dim i As Long, dic As Object, D Set dic = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Sheets("Sheet2") D = .Range("C2", .Cells(Rows.Count, 3).End(xlUp)).Offset(, -1).Resize(, 3) For i = 1 To UBound(D) If Not dic.exists(D(i, 2)) Then dic(D(i, 2)) = i End If Next End With With Sheets("Sheet1") For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row .Cells(i, 5) = D(dic(.Cells(i, 2).Value), 1) .Cells(i, 7) = D(dic(.Cells(i, 2).Value), 3) Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Set dic = Nothing End Sub

0

こんにちは。 遅いの改善なら、「設定するものがセル」なのを、正しくvalueにしたらいいのではないかと。 dicのサンプルコードは、itemとkeyを使うものです。 取り出しは、itemsで変数に取り出しするのですが、 今回の使い方は、重なりを排除したい、のでしょうか。 それでも、正しく動作している雰囲気に、見えません(気のせいならいいんでが) dic(.Cells(i, 3).Value) = Array(.Cells(i, 2), .Cells(i, 4)) この部分ですが、arrayをしないとしたら、なにがくるか、考えてください cells()は、cells().value にしたほうがいい、ということです