Q&A
コードのインデントが崩れてしまっていますので、コード部分を<code>タグで括ってください。
また、「エクセルの表」も提示された方が分かりやすいと思います。
機械設計関係の仕事をしています
なので製作に必要な物品等をまとめて上司にこのぐらい材料でお金がかかるというのを出しています
その際ミスミで参考価格を一件一件ネットで調べて金額を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.Offset(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をオブジェクトとしてセット objIE.Visible = True 'IEを開く 'ミスミを開く 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 .getElementById(“keyword_go“).Click 'Id要素 (keyword_go) をクリック End With '省略を終了 '移動後のページからリンクを選択 Set objShell = CreateObject(“Shell.Application“) 'Shellをオブジェクトとしてセット For Each objWindow In objShell.Windows 'ウィンドウの中から探す If objWindow.Name = “Internet Explorer“ Then Set objIE = objWindow '変数をセット Do While objIE.Busy Or objIE.readyState <> READYSTATE_COMPLETE DoEvents Loop 'ぺージの読み込みが完了するまで繰り返し処理 Call WaitFor(3) Set htmlDoc = objIE.document 'htmlDocをセット If InStr(htmlDoc.Title, strSite) > 0 Then 'htmlDocのタイトルの中からサイト名の文字列を探す For Each obj In htmlDoc.getElementsByTagName(“a“) If obj.innerText = KeyWD Then 'インナーテキストの(KeyWD) を探す Debug.Print obj.innerText obj.Click それをクリック Call WaitFor(4) Exit For End If Next End If End If Next 'KeyWDクリック後のページで数量変更し参考価格を確認 Set htmlDoc = objIE.document 'htmlDoctをセット Do While objIE.Busy Or objIE.readyState < READYSTATE_COMPLETE DoEvents Loop Call WaitFor(2) 'スクロール objIE.document.Script.setTimeout “javascript:scrollTo(0,500);“, 1000 Call WaitFor(2) For Each obj In htmlDoc.getElementsByClassName(“m-inputText--right“) 'ClassName “m-input Text--risht“を探して obj に格納 If obj.innerText = ““ Then 'その中から innerText が ““ を探して選択 obj.Value = Amount '値を Amount に書き換える Exit For End If Next For Each obj In htmlDoc.getElementsByClassName(“m-btn--checkPrice VN_opacity“) 'ClassName “m-btn--checkPrice VN_opacity“ を探して obj に格納 If obj.innerText = “価格を確認“ Then 'その中から innerText が “価格を確認“ を探して選択 obj.Click 'それをクリック End If Exit For Next Call WaitFor(5) Set htmlDoc = objIE.document For Each objTag In htmlDoc.getElementsByClassName(“m-cartBox__desc“) If objTag.tagname = “dd“ Then End If Exit For Next ActiveCell.Offset(0, 1).Select ActiveCell.Value = numExtract(objTag.innerText) objIE.Quit For Each objWindow In objShell.Windows Set objIE = objWindow objIE.Quit Set objIE = Nothing Set objShell = Nothing Set htmlDoc = Nothing Set objTag = Nothing Set obj = Nothing Call WaitFor(4) Exit For Next End Sub Function WaitFor(ByVal second As Integer) Dim futureTime As Date futureTime = DateAdd(“s“, second, Now) While Now < futureTime DoEvents Wend End Function Function numExtract(strValue 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: numExtract = numExtract & oneTxt Next i End Function
同じ質問を複数するのはやめましょうね♪
https://teratail.com/questions/238454
・コードは「コードの挿入」で記入してください。
・「繰り返し中に違う動きをし始めて止まってしまって」とは具体的にどういうことですか？
コードタグで括るのはこれでできてますか？
画像の投稿もできますか？
動作としては
ミスミで検索までは終わって次のページでアンカータグのkeywdを探してクリックさせるんですが
クリックせず？次のページでやるスクロールをしてしまっています
コードタグで括られていませんね。
コード部分を範囲選択して、<code>ボタンを押してください。
ヘルプ > 質問するときのヒント
https://teratail.com/help/question-tips#questionTips3-5
画像も投稿できます。
画像アイコンを押してください。
ヘルプ > 質問するときのヒント
https://teratail.com/help/question-tips#questionTips3-3
このコード、動かなくないですか？
"Offset" が そもそも "0ffset" になっていますし。
"If InStr(htmI Doc. Title, strSite) > 0 Then" も第一引数の中に空白が含まれていますし。
コードの構文というか、誤字脱字があるというか。
すいません、会社のパソコンからデータをとれないので写真解析アプリで解析して手直ししてます。
うまく読み取れなかったりしてます、
現状動いてます、そして何回か繰り返していると投稿した内容の動作をしてしまいます
最初のコードと少し違うみたいですね。
一度、上に提示されているコードを実行してもらえますか？
誤字脱字がある状態では実行できませんので。
あと、実行してみて質問の症状が再現されるかどうかも確認して下さい。
今日実行したところ
obj.innerText = "価格を確認" Then 'その中から innerText が "価格を確認" を探して選択 obi.Click 'それをクリック
の部分の読み込み時間が長くなると単価表示が間に合わずセルに書き込まず次の行に移動していました
そして何回かループしたら同じ現象で止まりました
今日実行したというのは、上に提示したコードを実行したということですか？
コード中にタイプミス等があると実行することさえできなかったりします。
まさに上に提示されたコードがそういう状況です。
回答者は上に提示されているコード以外は見れません。
上で提示したコードをVBEに貼り付けて実行してみて下さい。実行できないことがわかると思います。
最低限、実行できるコードを提示して下さい。
質問とは直接関係ないのですけど、
> 会社のパソコンからデータをとれないので写真解析アプリで解析して手直ししてます。
会社のPCからデータが取れないということは、情報漏洩を防ぐためにファイルの持ち出しを禁止している、などの理由がある気がしますが、ソースコードや画像、出してしまってよろしいのでしょうか。（＜ソーシャルハックと言って言えないことも無い） 許可を得ているのであれば良いと思いますけれども。
再度修正しました、スマホだと似ている記号もありまた誤字等あるかもしれないです
そこら辺はなんともいえないです。
コード等は自分が調べて書いたものなので他で実用性はないかと
会社の業務として書いたものでしょ。「なんとも言えない」現場レベルの判断で簡単に出してしまってはいけないでしょう。
責任とれませんよね。
あと、先に言っておくと、画像ですがユーザー側から削除できませんからね。HTMLのimgタグと同じです。あくまで呼び出し記述なのです。公開されてから２週間経ってますが、悪い人の目にとまってないといいですね。
回答2件
0
投稿先を間違えたため内容をクリアしました。
投稿2020/02/21 07:00
編集2020/02/21 07:05
総合スコア505
0
手打ちで入力したとのことですので、打ち間違い等もあると思いますが、
ざっと見て問題となりそうな点です。
(1)エラー処理がない。
たとえば品番間違いなどで検索結果がないときの動作が考慮されていない。
※途中まで動作するならこの可能性が大だと思います。
(2)サブルーチン呼び出しの度にIEオブジェクトを生成、削除しているため
処理コストが高い。
また、IEオブジェクトをQuitしてから実際にプロセスが削除されるまでには
少し時間がかかるため、生成、削除を繰り返すとオートメーションエラー
となることがある。
(3)別画面で表示されるIE画面を、画面一覧から得ているが、
複数のIE画面が開いている場合、そのうちのどれがヒットするかわから
ない。
(4)サブルーチンの終了時、関係ないIE画面もクローズしてしまう。
(5)スクロールは不要。
(6)「strSite」という変数/定数が未定義、未設定
(7)"m-btn--checkPrice VN_opacity"を探すループで
Exit Forがif文の外にあるため最初の1要素しかチェックしない。
(8)"m-cartBox__desc"を探すループ。(7)と同じ。
また, thenの中にステートメントがないので何も処理していない。
↓とりあえず書き直してみました。 waitForの秒数は調整してください。
Option Explicit Sub 参考価格所得() ' Dim base As Range: Set base = Range("E3") ' ' IEオブジェクトはループの外側で生成 ' Dim IE As Object: Set IE = CreateObject("InternetExplorer.Application") IE.Visible = True Dim rr As Long: rr = 1 Do Until base.Cells(rr, 1).Value = "" Dim a As String: a = base.Cells(rr, 1).Value ' 品番 Dim b As Long: b = base.Cells(rr, 5).Value ' 数量 base.Cells(rr, 6) = misumi検索(IE, a, b) rr = rr + 1 Loop IE.Quit Set IE = Nothing End Sub Function misumi検索(ByRef objIE As Object, ByVal KeyWD As String, ByVal Amount As Long) As Long misumi検索 = 0 objIE.navigate ("https://jp.misumi-ec.com/") Call waitLoad(objIE) Call WaitFor(3) ' ' 検索窓に製品コードを入れてクリック ' objIE.document.getElementById("keyword_input").Value = KeyWD objIE.document.getElementById("keyword_go").Click Call waitLoad(objIE) Call WaitFor(3) ' ' 検索結果画面のリンクを開く ' ※このリンクはクリックすると別画面が開いてしまうのでURLを生成して元のIEで開く ' Dim obj As Object Set obj = objIE.document.getElementsByClassName("m-media--code__main")(0).getElementsByTagName("a")(0) If (obj.innerText <> KeyWD) Then GoTo ERROREXIT Dim url As String: url = objIE.document.Location.protocol & "//" & objIE.document.Location.host & obj.getAttribute("href") Call objIE.navigate(url) Call waitLoad(objIE) Call WaitFor(5) ' ' 「注文数」を入れ「価格を確認」をクリック ' objIE.document.getElementsByClassName("m-inputText--right")(0).Value = Amount Set obj = objIE.document.getElementsByClassName("m-btn--checkPrice VN_opacity")(0) If (obj.innerText <> "価格を確認") Then GoTo ERROREXIT obj.Click Call waitLoad(objIE) Call WaitFor(3) ' ' 「合計」値を取得 ' Dim txt As String: txt = objIE.document.getElementsByClassName("m-cartBox__desc")(1).getElementsByTagName("SPAN")(0).innerText misumi検索 = Val(Replace(txt, ",", "")) ERROREXIT: Set obj = Nothing End Function Function waitLoad(ByRef IE As Object) Do While ie.Busy = True Or ie.readyState < READYSTATE_COMPLETE DoEvents Loop End Function Function WaitFor(ByVal second As Integer) Dim futureTime As Date futureTime = DateAdd("s", second, Now) While Now < futureTime DoEvents Wend End Function
投稿2020/02/10 07:51
総合スコア505
あなたの回答
tips
プレビュー
