EXCELマクロの処理時間を短縮したい

EXCELマクロの時間短縮で悩んでいます。どうかお知恵をお貸し下さい。（長文です）
Windows XP Pro
EXCEL 2002 を使用しています。
以下の作業の２．のところで２分以上　３．のところで２分以上の時間が掛かっています
マクロソースによるこれ以上の短縮は望めないでしょうか？　

＜作業内容＞
1. OLEDBを使って他のDBから
　トランザクション「Ａ」のデータを　シート「Ａ」に
　マスタ「Ｍ」のデータを　シート「Ｍ」に展開しています

2. シート「Ａ」のデータは　約４０，０００件　（変動します）

　番号　　 　基本番号＋枝番(1桁)　最初は基本番号＋0で変更があると枝番をカウントアップして追加
　最新番号　 変更が合った場合 変更の回数（枝番=0のレコードだけ更新)
　コード　　 名称コード　
　数量　　
　単価　　　 小数点以下　２桁まで
　追加数量　　
　追加単価

　　番号　　｜最新番号｜コード｜ 数量 ｜ 単価 ｜ 追加数量｜追加単価｜
　 1000010 ｜ 0 ｜123456｜ 1,000｜100.30｜ 10｜1,000.00｜
　 1000020 ｜ 2 ｜111111｜ 1,000｜200.50｜ 1｜5,000.00｜
　 1000021 ｜ 0 ｜111111｜ 900｜200.50｜ 2｜5,000.00｜
　 1000022 ｜ 0 ｜111111｜ 1,000｜200.00｜ 1｜5,000.00｜
　 1000030 ｜ 0 ｜123000｜ 2,500｜ 90.75｜ 0｜ 0.00｜
　 9500010 ｜ 0 ｜999999｜ 0｜ 0.00｜ 0｜ 0.00｜

　これを　シート「一覧」に基本番号別に枝番が最新の行をコピーして金額を出します
　約　３５，０００件になります

　基本番号 ｜コード｜　名称　｜ 数量 ｜ 単価 ｜ 追加数量｜追加単価｜　金額
　 100001 ｜123456｜ ｜ 1,000｜100.30｜ 10｜1,000.00｜110,300
　 100002 ｜111111｜ ｜ 1,000｜200.00｜ 1｜5,000.00｜205,000
　 100003 ｜123000｜ ｜ 2,500｜ 90.75｜ 0｜ 0.00｜226,875

3. シート「Ｍ」のデータは　約３０，０００件　（変動します）

　 コード　｜　　名称　　｜
　　 111111｜ AAAAAAAAAA ｜
123000｜ ABCDEFGHIJ ｜
123456｜ BBBBBBBBBB ｜

　シート「一覧」の名称に名称を入れます

　基本番号 ｜コード｜　　名称　｜ 数量 ｜ 単価 ｜ 追加数量｜追加単価｜　金額
　 100001 ｜123456｜BBBBBBBBBB｜ 1,000｜100.30｜ 10｜1,000.00｜110,300
　 100002 ｜111111｜AAAAAAAAAA｜ 1,000｜200.00｜ 1｜5,000.00｜205,000
　 100003 ｜123000｜ABCDEFGHIJ｜ 2,500｜ 90.75｜ 0｜ 0.00｜226,875

＜マクロ　ソース＞
Sub 一覧作成()

Dim i As Long, j As Long, k As Long, read_no As Long
Dim jlist As Worksheet, jdata As Worksheet
Dim v As Variant, w As Variant
Dim dic As Object

Application.ScreenUpdating = False '画面停止
'ＤＢ取り込み　※省略

Set jlist = Worksheets("一覧")'処理２
Set jdata = Worksheets("Ａ")
jlist.Cells.ClearContents
jlist.Range("A1").Value = "基本番号"
jlist.Range("B1").Value = "コード"
jlist.Range("C1").Value = "名称"
jlist.Range("D1").Value = "数量"
jlist.Range("E1").Value = "単価"
jlist.Range("F1").Value = "追加数量"
jlist.Range("G1").Value = "追加単価"
jlist.Range("H1").Value = "金額"

i = 2 '今読んでる行
k = 2 '書いている行
j = 0 '枝番が合った場合　飛ばす行
read_no = 0

Do While jdata.Cells(i, 1).Value < 9500000
read_no = jdata.Cells(i, 1).Value / 10
j = 0
If jdata.Cells(i, 2).Value <> 0 Then '枝番有
j = judata.Cells(i, 2)
End If
i = i + j
jlist.Cells(k, 1).Value = Format(read_no, "000000")
jlist.Cells(k, 2).Value = jdata.Cells(i, 3).Value
jlist.Cells(k, 4).Value = jdata.Cells(i, 4).Value
jlist.Cells(k, 5).Value = jdata.Cells(i, 5).Value
jlist.Cells(k, 6).Value = jdata.Cells(i, 6).Value
jlist.Cells(k, 7).Value = jdata.Cells(i, 7).Value
jlist.Cells(k, 8).Value = _
Application.RoundDown((jdata.Cells(i, 4).Value * jdata.Cells(i, 5).Value + _
jdata.Cells(i, 6).Value * jdata.Cells(i, 7).Value), 0)
k = k + 1
i = i + 1
Loop

Set jname = Worksheets("Ｍ")'処理３
With jname
With .Range("B2", .Cells(.Rows.Count, 1).End(xlUp))
v = .Columns(1).Value
w = .Columns(2).Value
End With
End With
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(v)
dic(v(i, 1)) = i
Next
With jlist
With .Range("B2", .Cells(Rows.Count, 4).End(xlUp)) 'B2～Dの最終行まで
v = .Value
For i = 1 To UBound(v)
If dic.exists(v(i, 1)) Then
v(i, 2) = w(dic(v(i, 1)), 1)
Else
v(i, 2) = "無"
End If
Next
With .Offset(0, 0)
.ClearContents
.Value = v
End With
End With
End With

Set dic = Nothing
Set jlist = Nothing
Set jname = Nothing
Application.ScreenUpdating = True

End Sub

No.2 ベストアンサー 回答者： end-u 回答日時： 2011/09/26 20:21

>Do While jdata.Cells(i, 1).Value < 9500000

>　　read_no = jdata.Cells(i, 1).Value / 10
>　　j = 0
>　　If jdata.Cells(i, 2).Value <> 0 Then　　'枝番有
>　　　　j = judata.Cells(i, 2)
>　　End If
>　　i = i + j
>　　jlist.Cells(k, 1).Value = Format(read_no, "000000")
>　　jlist.Cells(k, 2).Value = jdata.Cells(i, 3).Value
>　　jlist.Cells(k, 4).Value = jdata.Cells(i, 4).Value
>　　jlist.Cells(k, 5).Value = jdata.Cells(i, 5).Value
>　　jlist.Cells(k, 6).Value = jdata.Cells(i, 6).Value
>　　jlist.Cells(k, 7).Value = jdata.Cells(i, 7).Value
>　　jlist.Cells(k, 8).Value = _
>　　Application.RoundDown((jdata.Cells(i, 4).Value * jdata.Cells(i, 5).Value + _
>　　　　　　　　　　　　　 jdata.Cells(i, 6).Value * jdata.Cells(i, 7).Value), 0)
>　　k = k + 1
>　　i = i + 1
>Loop
この箇所、１セルずつ書き込んでいますから遅いです。
Sheets("Ａ")のデータを配列に取り込んで、同行８列の配列を作って処理し、
Sheets("一覧")に一括で書き込むようにしたほうが速くなります。
具体的には

>'i = 2　　　 '今読んでる行
>'k = 2　　　 '書いている行
>'j = 0　　　 '枝番が合った場合　飛ばす行
>'read_no = 0
以上は不要。
：
With jdata
　　'Sheets("Ａ")のA列最下行からG2セルまでのデータ部を配列に
　　v = .Range("G2", .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
'vと同サイズ（列は８）の空配列準備
ReDim w(1 To UBound(v), 1 To 8)
'書き込み位置
k = 0
'配列１次元の要素の数だけLoop
For i = 1 To UBound(v)
　　'一応、Loop終了条件踏襲
　　If v(i, 1) >= 9500000 Then
　　　　Exit For
　　End If
　　read_no = v(i, 1) / 10
　　If v(i, 2) <> 0 Then　'枝番有
　　　　i = i + v(i, 2)
　　End If
　　k = k + 1
　　w(k, 1) = Format(read_no, "000000")
　　w(k, 2) = v(i, 3)
　　w(k, 4) = v(i, 4)
　　w(k, 5) = v(i, 5)
　　w(k, 6) = v(i, 6)
　　w(k, 7) = v(i, 7)
　　w(k, 8) = Application.RoundDown((v(i, 4) * v(i, 5) + _
　　　　　　　　　　　　　　　　　　 v(i, 6) * v(i, 7)), 0)
Next
'kがwの書き込み数なのでSheets("一覧")の範囲をResizeして書き込み
jlist.Range("A2:H2").Resize(k).Value = w
：
こんな感じです。
もしかしたらRoundDown計算は一度Sheets("Ａ")のH列でやってから
配列に一緒に取り込むようにしたほうが速いかもしれません。
また、dictionaryを使った名称セットも
上記Loopの中でやってしまっても良いかもしれませんね。

この回答へのお礼

ありがとうございます。
おかげ様で２．の処理があっという間に終わるようになりました。
No.3で頂いた回答と合せて　５分近く掛かっていた処理が30秒掛からず終了するようになりました。
回答して頂いた皆様に感謝いたします。

お礼日時：2011/09/27 14:29

No.4 回答者： mitarashi 回答日時： 2011/09/27 00:37

3の所だけ試験データを作成してやってみました。

xl2000,WindowsXP SP3,PentiumM 1.3Gの古いマシンです。
ご提示のコードより単純な方法で、同等の事をしているつもりですが、数秒で終了しました。ご参考まで。
Sub test3()
Dim myDic As Object
Dim i As Long
Dim targetRange As Range
Dim buf As Variant

Application.ScreenUpdating = False
Set myDic = CreateObject("scripting.dictionary")
Set targetRange = Sheets("M").Range("A2:B30001")
buf = targetRange
For i = LBound(buf, 1) To UBound(buf, 1)
myDic.Add buf(i, 1), buf(i, 2)
Next i
Set targetRange = Sheets("一覧").Range("A2:H35001")
buf = targetRange
For i = LBound(buf, 1) To UBound(buf, 1)
If myDic.exists(buf(i, 2)) Then
buf(i, 3) = myDic(buf(i, 2))
Else
buf(i, 3) = "無"
End If
Next i
targetRange = buf
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます。
皆様にお教え頂いた結果　時間短縮に成功いたしました。

お礼日時：2011/09/27 14:34

No.3 回答者： end-u 回答日時： 2011/09/26 20:59

>..３．のところで２分以上..

処理３はdictionaryと配列を使ってるのにそんなにかかりますか。
ひょっとしたら別の原因で遅くなってるのかも。
ScreenUpdatingプロパティだけではなく、
（処理前）
Dim x As Long
With Application
　　x = .Calculation
　　.Calculation = xlCalculationManual
　　.EnableEvents = False
　　.ScreenUpdating = False
End With
：
（処理後）
With Application
　　.Calculation = x
　　.EnableEvents = True
　　.ScreenUpdating = True
End With
のように、イベントと再計算の制御もやったほうが良いかもしれません。



それに処理３を弄るとしたら
：
Set jname = Worksheets("Ｍ")
With jname
　　With .Range("B2", .Cells(.Rows.Count, 1).End(xlUp))
　　　　v = .Columns(1).Value
　　　　w = .Columns(2).Value
　　End With
End With
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(v)
　　dic(CStr(v(i, 1))) = i
Next
With jlist
　　With .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
　　　　v = .Value
　　　　ReDim z(1 To UBound(v), 0) As String
　　　　For i = 1 To UBound(v)
　　　　　　j = dic(CStr(v(i, 1)))
　　　　　　If j = 0 Then
　　　　　　　　z(i, 0) = "無"
　　　　　　Else
　　　　　　　　z(i, 0) = w(j, 1)
　　　　　　End If
　　　　Next
　　　　.Offset(, 1).Value = z
　　End With
End With
こんな感じでしょうか。

この回答へのお礼

ありがとうございます。
おかげ様で　３．の処理が10秒程度で終わるようになりました。

お礼日時：2011/09/27 14:22

No.1 回答者： imogasi 回答日時： 2011/09/26 18:24

望む回答ではないだろうが、

（１）２つのエクセルシートに、OLEDBを使って他のDBから、　トランザクション「Ａ」のデータを　シート「Ａ」に　マスタ「Ｍ」のデータを　シート「Ｍ」に展開して、処理はせずに時間を計る（プログラムを加える）。
シートデータを一旦保存。
（２）次に（データベースのデータは使わず・読まず）両シートだけを読んで処理するプログラムに（改変は一部で済むと思うが）変える。
（処理時間を計るプログラムを加える）
（２）では現状より相当短縮されるなら、OLEDBを使って他のDBから、エクセルシートへが要因ではないか。
原因追求には、どんなことでも、こういう切り分けが必要だろう。
２重ループもないようだし、コードだけから割り出すのは難しいのでは。
木になるのはＦＳＯのＤｉｃｔｉｏｎａｒｙという素人受けの仕組みを使っているようなこと。
すばらしい仕組みだが時間はかかるのではないかな。
ソート法でソートし、マッチングアルゴリズムを使えば速くなると思うが、やっている内容がよくわからないので何ともいえない。
＝＝＝
別のことだが、全体的に何がしたいのか、質問文章で表現できないのか。
質問にはSet jlist = Worksheets("一覧")'処理２からjlist.Range("H1").Value = "金額"までなど１回限りのことで書く必要は無いだろう。
前半は１歩１歩書いてあるようでいて、その後は単純な順処理なのか、マッチング的なことなのか何がしたいのか、判りにくい。
データは再現できないし、テストも出来ない。
もっと読者・回答者のことを慮って、質問の表現・内容を考えててほしい。コードを丸写しでなく、処理内容の解説がほしい。この質問を見たらパスする人が多いのでは。

この回答へのお礼

ありがとうございます。
文章が判りにくく申し訳ありません。ご親切な皆様に助けていただいています。

お礼日時：2011/09/27 14:11