呼び出し 削除
| Message#1 2015年11月13日(金)11時38分 From: VBA悩み |
| 下記の@、Aの二つを一連の作業（呼び出しOR記述）にしたいと考えています。 @をベースにAを組み込みたいです。 長文で申し訳ありませんが宜しくお願いします。 @ Sub PrSerch() Dim rc As Integer rc = MsgBox("処理を行いますか？", vbYesNo + vbQuestion, "確認") If rc = vbYes Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim objIE As InternetExplorer Dim i As Integer Dim NN As Long Dim h As Long Dim jn As Long Dim maxrow As Long Dim t As Variant Dim myAry1 Dim ws1 As Object Dim sline As Variant 'sline = Range("S2:S1000") Set ws1 = Workbooks("商品search").Worksheets("CheckSheet") 'ストップウォッチ t = Timer 'データの最終行取得 maxrow = ws1.Cells(Rows.Count, 19).End(xlUp).Row Debug.Print maxrow 'ループ処理 For jn = 2 To maxrow If Cells(jn, 19) = "" Then End If If Cells(jn, 19) <> "" Then 'データ抽出用ページをIE（InternetExplorer）で起動 Call ieView(objIE, "https://www.berrys1.jp/stock/stock.t.html") '検索窓に「検索ワード」を入力 objIE.Document.getElementById("itemcode").Value = Cells(jn, 19) 'Click前のLink数を記憶（これが変化するとの前提) NN = objIE.Document.Links.Length '検索ボタンを押す Call IEButtonClick(objIE, "検索") Sleep 800 '無限ループを避けるため上限を1秒に Do Until objIE.Document.Links.Length <> NN Or i > 10 DoEvents Sleep 100 i = i + 1 Loop If i > 10 Then End If Select Case objIE.Document.Links.Length Case NN SendKeys "{ENTER}" objIE.Quit Case Else 'a要素をクリックする objIE.Document.Links(0).Click '0.5秒待ち Sleep 500 '全てのｔｄが表示された場合の条件分岐 If objIE.Document.getElementsByTagName("td").Length <> 4 Then '金額("td")(13)を変数に入れる 対象のセルに入力 h = objIE.Document.all.tags("td")(13).innerHTML ws1.Cells(jn, 5) = h '閉じてお掃除 objIE.Quit Set objIE = Nothing Else SendKeys "{ENTER}" objIE.Quit End If End Select End If ※※このあたりに組み込みたい※※ Next jn Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Else MsgBox "処理を中断します" End If '確認の終わり Debug.Print Timer - t End Sub A Sub joutai() Dim rc As Integer rc = MsgBox("処理を行いますか？", vbYesNo + vbQuestion, "確認") If rc = vbYes Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim objIE As InternetExplorer Dim i As Integer Dim NN As Long Dim NN2 As Long Dim NN3 As Variant Dim h As String Dim jn As Long Dim k As Integer Dim maxrow As Long Dim t As Variant Dim myAry1 Dim ws1 As Object Dim ss As Object Dim per As Double Set ws1 = Workbooks("商品search").Worksheets("CheckSheet") 'データの最終行取得 maxrow = ws1.Cells(Rows.Count, 20).End(xlUp).Row per = Cells(1, 21) For jn = 2 To maxrow If Cells(jn, 20) < per Then End If If Cells(jn, 20) >= per Then 'データ抽出用ページをIE（InternetExplorer）で起動 Call ieView(objIE, "https://www.berrys1.jp/stock/stock.t.html") '検索窓に「検索ワード」を入力 objIE.Document.getElementById("itemcode").Value = Cells(jn, 19) 'Click前のLink数を記憶（これが変化するとの前提) NN = objIE.Document.Links.Length '検索ボタンを押す Call IEButtonClick(objIE, "検索") Sleep 800 '無限ループを避けるため上限を1秒に Do Until objIE.Document.Links.Length <> NN Or i > 10 DoEvents Sleep 100 i = i + 1 Loop If i > 10 Then End If Select Case objIE.Document.Links.Length Case NN SendKeys "{ENTER}" objIE.Quit Case Else 'a要素をクリックする objIE.Document.Links(0).Click '0.5秒待ち Sleep 500 '全てのｔｄが表示された場合の条件分岐 If objIE.Document.getElementsByTagName("td").Length <> 4 Then Set ss = objIE.Document.all.tags("td") For k = 14 To ss.Length - 2 If ss(k).innerHTML = "在庫(ＬＡＢＩ品川大井町店)" Then h = ss(k + 1).innerHTML ws1.Cells(jn, 16) = h ElseIf ss(k).innerHTML = "在庫(Ｌ１日本総本店池袋)" Then h = ss(k + 1).innerHTML ws1.Cells(jn, 14) = h ElseIf ss(k).innerHTML = "在庫(ＬＡＢＩ新宿東口館)" Then h = ss(k + 1).innerHTML ws1.Cells(jn, 15) = h ElseIf ss(k).innerHTML = "在庫(京葉配工センター)" Then h = ss(k + 1).innerHTML ws1.Cells(jn, 17) = h End If Next k Else SendKeys "{ENTER}" objIE.Quit End If objIE.Quit Set objIE = Nothing End Select End If Next jn Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Else MsgBox "処理を中断します" '確認の終わり End If End Sub |
上のメッセージを削除します。
よければパスワードを入力し、削除ボタンをクリックしてください。
