JustAnswer のしくみ:

  • 専門家に質問
    知識豊富な専門家があらゆる質問にお答えするために常に待機しています。
  • 専門家が丁寧に対応
    E メールやサイト内オンラインメッセージなど、さまざまな手段で回答を通知。
    必要に応じてフォローアップの質問をすることもできます。
  • 満足度 100% 保証
    専門家からの回答を確認し評価をすることで、支払うかどうかを決めます。

tsukuba_frogに今すぐ質問する

tsukuba_frog
tsukuba_frog, ITエンジニア
カテゴリ: IT・インターネット
満足したユーザー: 41
経験:  IT Professional
65805256
ここに IT・インターネット に関する質問を入力してください。
tsukuba_frogがオンラインで質問受付中

先ほどの質問の続きです。 「 --- 各CODEの検索と貼付 --- ここの処理の高速化が必要」内、記述を修正いたしましたが、ループ処理に時間がかかって処理が遅いよ

解決済みの質問:

先ほどの質問の続きです。
「' --- 各CODEの検索と貼付 --- ここの処理の高速化が必要」内、記述を修正いたしましたが、ループ処理に時間がかかって処理が遅いように思います。
このループ処理以外の方法がしりたいのですが、よろしくおねがいいたします。
Dim VarFileName As Variant
VarFileName = Application.GetOpenFilename("エクセルファイル,*.xls;*.xlsm", , "PLEMIA資材コードファイルを開く")
If VarFileName = False Then
sRtncd = -1: o_tError = "キャンセルされました。"
GoTo L_END
Else
Workbooks.Open Filename:=VarFileName, ReadOnly:=True
Set CurrentBook = ActiveWorkbook
End If


' --- 列情報の検索 ---
BomCodeCol = Cells.Find("資材コード", Lookat:=xlWhole).Column
BomNameCol = Cells.Find("名称", Lookat:=xlWhole).Column
BomSpecCol = Cells.Find("No", Lookat:=xlWhole).Column
BomMakeCol = Cells.Find("メーカー", Lookat:=xlWhole).Column
BomToriCol = Cells.Find("参考納入業者", Lookat:=xlWhole).Column
LineCount = Range("A1").End(xlDown).Row ' --- 検索行数設定

'資材コードをキーにして昇順にソート
Range(Cells(2, 1), Cells(Range("A1").End(xlDown).Row, Range("A1").End(xlToRight).Column)).Sort Key1:=Range(Cells(1, BomCodeCol), Cells(1, BomCodeCol)), order1:=xlAscending


ActiveSheet.Copy after:=aWorkBook.Worksheets("sheet1")
ActiveSheet.Name = "Sheet2"

Workbooks(CurrentBook.Name).Close SaveChanges:=False


' --- 各CODEの検索と貼付 --- ここの処理の高速化が必要
For i = 2 To LineCount
BomCode = Worksheets("Sheet2").Cells(i, BomCodeCol).Value ' --- 資材CODEを検索キーに設定
' BomName = Worksheets("Sheet2").Cells(i, BomNameCol).Value ' --- 品名(日本語)
' BomSpec = Worksheets("Sheet2").Cells(i, BomSpecCol).Value ' --- 仕様(日本語)の検索
' BomMake = Worksheets("Sheet2").Cells(i, BomMakeCol).Value ' --- MAKER名の検索
' BomTori = Worksheets("Sheet2").Cells(i, BomToriCol).Value ' --- 取引先名の検索
' aWorkBook.Activate
If BomCode = "" Then ' 資材CODEが無い時
Worksheets("Sheet1").Cells(Worksheets("Sheet1").Range("A1").End(xlDown).Row + 1, 1).Value = "該当なし"
YLine = Worksheets("Sheet1").Range("A1").End(xlDown).Row
Else
Set Obj = Worksheets("Sheet1").Range("A").Cells.Find(BomCode)
If Obj Is Nothing Then ' 資材CODEが見つからない時
Worksheets("Sheet1").Cells(Worksheets("Sheet1").Range("A1").End(xlDown).Row + 1, 1).Value = BomCode
YLine = Worksheets("Sheet1").Range("A1").End(xlDown).Row
Else ' 資材コードが見つかった時
YLine = Obj.Row
End If
End If
' その他情報を設定
Worksheets("Sheet2").Cells(i, BomNameCol).Copy Destination:=Worksheets("Sheet1").Cells(YLine, 4) ' 品名
Worksheets("Sheet2").Cells(i, BomSpecCol).Copy Destination:=Worksheets("Sheet1").Cells(YLine, 6) ' 仕様
Worksheets("Sheet2").Cells(i, BomMakeCol).Copy Destination:=Worksheets("Sheet1").Cells(YLine, 8) ' メーカ
Worksheets("Sheet2").Cells(i, BomToriCol).Copy Destination:=Worksheets("Sheet1").Cells(YLine, 10) ' 取引先
Next i

L_END: ' --- 終了処理 ---
Application.DisplayAlerts = False
Worksheets("Sheet2").Delete
Application.DisplayAlerts = True
PlemiaInfo = sRtncd

End Function
投稿: 4 年 前.
カテゴリ: IT・インターネット
専門家:  tsukuba_frog 返答済み 4 年 前.

一点確認させてください。
この処理は、「Sheet1にある資材マスターの情報を更新・追加する処理」
で間違いないでしょうか?

質問者: 返答済み 4 年 前.
<資材>部品マスタ.xlsの資材CODEと資材コード.xlsの資材コードの差分です
専門家:  tsukuba_frog 返答済み 4 年 前.


' --- 各CODEの検索と貼付 --- ここの処理の高速化が必要
Dim ws1 As Worksheet
Set ws1 = Worksheets("Sheet1")

Dim rowlast
rowlast = ws1.Range("A1").End(xlDown).Row

'Sheet1のコードと列番号を辞書にセットする
'これを使うことで、コードから該当する列番号が高速に取得できる
Dim dic As Scripting.Dictionary
Set dicCodeRow = New Dictionary

For i = 2 To rowlast
code = ws1.Cells(i, 1).Value
dicCodeRow.Add code, i
Next

'該当なし、やコードなしの場合で行追加を行うときの行番号管理用
Dim rownext
rownext = rowlast + 1

Application.ScreenUpdating = False
Dim ws2 As Worksheet
Set ws2 = Worksheets("Sheet2")
Dim LineCount
LineCount = ws2.Range("A1").End(xlDown).Row
For i = 2 To LineCount
BomCode = ws2.Cells(i, BomCodeCol).Value
If BomCode = "" Then ' CODEが無い時
'該当無し、で行を追加
ws1.Cells(rownext, 1).Value = "該当なし"
YLine = rownext
rownext = rownext + 1
'シートから検索するのではなく、辞書から検索して行を取得する
ElseIf Not dicCodeRow.Exists(BomCode) Then ' CODEが見つからない時
'追加のコードで行を追加
ws1.Cells(rownext, 1).Value = BomCode
YLine = rownext
'辞書に追加する
dicCodeRow.Add BomCode, rownext
rownext = rownext + 1
Else
'コードが一致する行番号を取得
YLine = dicCodeRow(BomCode)
End If
'値をセット
ws1.Cells(YLine, 4).Value = ws2.Cells(i, BomNameCol).Value ' 品名
ws1.Cells(YLine, 6).Value = ws2.Cells(i, BomSpecCol).Value ' 仕様
ws1.Cells(YLine, 8).Value = ws2.Cells(i, BomMakeCol).Value ' メーカ
ws1.Cells(YLine, 10).Value = ws2.Cells(i, BomToriCol).Value ' 取引先
Next
Application.ScreenUpdating = True
L_END: ' --- 終了処理 ---

こんな感じで同じ機能になるかな…と思いますが
いかがでしょうか。

ただしこちらを試す場合、[ツール]-[参照設定]から「Microsoft Scripting Runtime」をチェックして有効にしてください。

なお、その前にまず、上記のプログラムにも含まれていますが
Application.ScreenUpdating = False

Application.ScreenUpdating = True
で、ループの処理を挟んでみてください。
この命令は画面の表示の更新を止める事で、データ処理を高速にする作用があります。

ご参考にしてみてください。
tsukuba_frog, ITエンジニア
満足したユーザー: 41
経験: IT Professional
tsukuba_frogをはじめその他名のIT・インターネットカテゴリの専門家が質問受付中
質問者: 返答済み 4 年 前.

'Sheet1のコードと列番号を辞書にセットする
'これを使うことで、コードから該当する列番号が高速に取得できる
Dim dic As Scripting.Dictionary
Set dicCodeRow = New Dictionary


 


コンパイルエラーがでます

質問者: 返答済み 4 年 前.

Dim dic As Scripting.Dictionary
Set dicCodeRow = New Dictionary


でコンパイルエラーが出ます。


現在まで質問している内容のコードは私自身がコーディングしたものではなく、別の方がしております。処理速度が遅いということでコーディングの修正依頼を受け質問しておりますが、殆どわかっていません。FOR文の内容と先細頂いた辞書として登録し検索をするといった内容は結果は同じなのでしょうか?

専門家:  tsukuba_frog 返答済み 4 年 前.

コンパイルエラーとの事ですが、
先の回答ではさらっと一行で書きましたが
・VBAのウィンドウで[ツール]-[参照設定]をクリックし、
・表示されたダイアログの「参照可能なライブラリファイル」の一覧の中の「Microsoft Scripting Runtime」を探してチェックし
・[OK]でダイアログを閉じる
という設定をしていただく必要がありますが
そちらはなさいましたでしょうか?
それを行えば大丈夫なはずです。


処理の結果は、同じになる「はず」です。
私としてはご提示されたソースコードを読み、同じ動きとなるよう注意して書き直したものです。
ですが、実際に扱うデータについてはプログラムソースから想像するしかないため、
ひょっとすると考え違いがある可能性は正直に言いましてゼロではありません。

ですので、もし私が書き直したものを使ってみるとしても、
念のため現行のファイルは確実にバックアップを取っておいて、
何パターンかのデータに対して現行のものと、書き直したものとで処理を行って
大丈夫かどうかの判断はご質問者様の方でして頂くしかありません。

私としましては、ご回答としてお送りしましたソースコードを
ご質問者様の方でお読みになり、不明点は自学なさるなどして
ご理解いただける事を、願っております。

ユーザーの声:

 
 
 
  • なかなか解決できないトラブルだったのですが、解決までとことん相談にのってくださいました。また、パソコンをうまく使いこなせていない私でも解りやすくアドバイスしてくださいました。 本当に助かりました! 大阪府 黒崎
< 前へ | 次へ >
  • なかなか解決できないトラブルだったのですが、解決までとことん相談にのってくださいました。また、パソコンをうまく使いこなせていない私でも解りやすくアドバイスしてくださいました。 本当に助かりました! 大阪府 黒崎
  • パソコンの操作は熟知している訳でもなく不慣れですが何回もの質問に丁寧に答えていただき問題解決しました、大変助かりました、感謝しています。 兵庫県明石市 後藤
  • 回答が早く、2日間対処には時間がかかりましたが、80%諦めていたものが解決したので、とにかく感謝の一言です。 ありがとうございました。 千葉県野田市 金澤
  • まずは親身になって回答をして頂ける専門家であったこと。説明が簡潔でわかりやすく、質問者が気持ちの整理をしやすい配慮が伺えた。 岐阜県 石川
  • 短時間で的確なアドバイスを受けることができ、かつ、回答に対する質問に対しても直ちに真摯な回答が得られました。 大阪府高槻市 川嶋
  • 専門知識のある経験豊富な方に出会う機会のない人でも、このサイトで実現出来ることは素晴らしいことだと思いました。 専門家が辛抱強く回答をしてくださる姿勢にも感謝いたしました。 茨城県日立市 池田
 
 
 

専門家の紹介:

 
 
 
  • DKK2002

    DKK2002

    ITエンジニア

    満足した利用者:

    821
    NTTコミュニケーションズ .com Master★★
  • http://ww2.justanswer.com/uploads/KW/kwskmkt/2011-7-4_13263_DSC04002.64x64.JPG DKK2002 さんのアバター

    DKK2002

    ITエンジニア

    満足した利用者:

    821
    NTTコミュニケーションズ .com Master★★
  • http://ww2.justanswer.com/uploads/RU/rushqk/2011-9-24_21937_CIMG0197.64x64.jpg rushqk さんのアバター

    rushqk

    ITエンジニア

    満足した利用者:

    94
    AV機器開発設計
  • http://ww2.justanswer.com/uploads/OC/oct1290/2012-4-17_123618_akodesu.64x64.JPG oct1290 さんのアバター

    oct1290

    ITエンジニア

    満足した利用者:

    38
    日本製PCメーカー顧客、企業サポート官庁PCサポート海外3店舗のPC修理業
  • http://ww2.justanswer.com/uploads/HO/holodecks/2011-10-21_0147_20111021091343.64x64.jpg holodecks さんのアバター

    holodecks

    情報整理戦略コンサルタント

    満足した利用者:

    2
    化学科卒システム計画研究所 - シニアシステムエンジニア、ディー・リンク株式会社 取締役
  • http://ww2.justanswer.com/uploads/SP/Spinnaker0921/2011-5-28_232633_Spinnaker.64x64.JPG Spinnaker0921 さんのアバター

    Spinnaker0921

    ITエンジニア

    満足した利用者:

    0
    PC/WS製造・サポート専門です。
  • http://ww2.justanswer.com/uploads/OB/obody/2015-6-17_162039_photo.64x64.jpg Nobody_1963 さんのアバター

    Nobody_1963

    ITエンジニア

    満足した利用者:

    58
    Windows Expert
  • /img/opt/shirt.png dueprocess さんのアバター

    dueprocess

    ITエンジニア

    満足した利用者:

    397
    中央大学卒・行政書士事務所経営・特定行政書士