ループしていくと途中で違う動作をしてしまう

機械設計関係の仕事をしています
なので製作に必要な物品等をまとめて上司にこのぐらい材料でお金がかかるというのを出しています
その際ミスミで参考価格を一件一件ネットで調べて金額をExcelに手打ちしています。
なのでVBAでリストに品番だけ手打ちしてあとはセルから品番をミスミの検索窓に入力、品番のページにて単価を抜き取り、セルの単価列に入力をセルに品番がなくなるまで繰り返し行うコードを初VBAながらネットで調べながら動く様になったのですが、繰り返し中に違う動きをし始めて止まってしまってわからなくなりました。どこが悪いかわからず手が出せない状態です。あともう少し軽く、シンプルにする方法はありますでしょう？

コード
Sub 参考価格所得

'Macrol Macro

'品番を記憶
Range("E3").Select
'セル　E3を選択
Do Until ActiveCell.Value =　""
a = ActiveCell.Value
'aにアクティブセルの値を書き込み
ActiveCell.Offset (0, 4). Select
b = ActiveCell.Value
'bにアクティブセルの値を書き込み
Call misumi検索 (a, b)
'プロシージャ misumi検索を呼び出し
ActiveCell.0ffset (1, -5).Select
Loop
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub misumi検索 (KeyWD, Amount)

'変数を宣言
Dim objIE As InternetExplorer
Dim htmlDoc As HTMLDocument
Dim objShell As Object
Dim obj As Object
Dim objTag As Object
Dim objWindow As Object

'IEを開く
Set objIE = CreateObject("InternetExplorer.Application")
'IEをオブジェクトとしてセット
obiIE.Visible = True
'ミスミを開く
objIE.navigate "https://jp.misumi-ec.com/"
'指定のURLにアクセス
Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop
'ページの読み込みが完了するまで繰り返し処理
Call WaitFor(3)
'検索Boxに aを入力して検索をクリック
Set htmlDoc = objIE.document
'htmlDocをセット
With htmlDoc
'htmlDocを省略
.getElementById("keyword_input ").Value = KeyWD
Id要素 (keyword_input) KeyWD
getElementByld("keywordgo").Click
'I要素 (keyword_go) をクリック
End With
移動後のページからリンクを選択
Set obj Shell = CreateObject("Shell.Application")
'Shellをオプジェクトとしてセット
For Each obiWindow In objShell.Windows
ウィンドウの中から探す
If objWindow. Name = "Internet Explorer" Then
Set objIE = objWindow
*変数をセット
Do While obj IE.Busy Or obj IE. readyState <> READYS
DoEvents
dooj
ベージの読み込みが完了するまで
繰り返し処理
Call WaitFor(3)
Set htmlDoc = objIE.document
*htmlDocをセット
If InStr(htmI Doc. Title, strSite) > 0 Then
'htmlDocのタイィトルの中からサイト名の文字列をメッセージボッ
For Each obj In htmlDoc. getElementsByTasName ("a")
If obj.innerText = KeyWD Then
Debug. Print obi.innerText
インナーテキストの(KeyWD) を探す
obi.Click
それをクリック
Call WaitFor(4)
Exit For
End If
Next
End If
End If
Next
Gene ral)
"KeyWDクリック後のページで数量変更し参考価格を確認
Set htmlDoc = obj IE.document
'htmlDoct
Do While objIE.Busy Or obi IE. readyState < READYSTATE COMPLETE
DoEvents
dooj
Çall WaitFor(2)
スクロール
obj IE.document.Script.setTi meout "javascript:scrolITo(0,500);", 1000
Call WaitFor(2)
For Each obi In htmlDoc.getElementsByClassName("m-input Text--right")
'ClassName "m-input Text--risht
If obj.innerlText =
その中から innerText が
obi. Value = Amount
値を Amount に書き換える
Exit For
End If
Next
For Each obi In htmlDoc.getElementsByClassName ("m-btn--checkPrice VN opacity
ClassName "m-btn--checkPrice VN opacity"
obj.innerText = "f " Then
ジの読み込みが完了するまで練り返し処理
を全て探してobj に格納する
Then
**を探して選択
を全て探してobj に格納する
innerText i
G4中0と
obi.Click
Exit For
Next
Call WaitFor(3)
Set htmlDoc : objIE.document
For Each objTag In htmlDoc.getElement sByClassName("m-cartBox__desc")
1f obi Tag.tagname = "dd" Then
Exit For
Next
Act iveCell.0ffset (0. 1). Select
Act i veÇell.Value = numExt ract (obiTag. innerText)
obj IE.Quit
For Each obi Window In obj Shell.Windows
Set obj IE = objWindow
ob i IE. Ouit
Set obiIE = Nothing
Set obj Shel|
Set htmlDoc = Nothing
Set obiTas = Nothing
Set obi Nothins
Call WaitFor (4)
Exit For
Next
End Sub
Funct i on Wait For (ByVal second As Integer)
Dim futureTime As Date
futureTime = DateAdd("s"
While Now < futureTime
DoEvents
Wend
End Funct ion
second. Now)
Function numExtract (st rValue As String) As String
Dim i As Integer
For i = 1 To Len(strValue)
oneTxt = Mid(strValue. i, 1)
If oneTxt Like "[0-9]" Then: numExt ract = numExt ract & oneTxt
Next i
End Funct i on